#!/usr/bin/env perl -W
#
# %CopyrightBegin%
#
# SPDX-License-Identifier: Apache-2.0
#
# Copyright Ericsson AB 1998-2025. All Rights Reserved.
#
# Licensed under the Apache License, Version 2.0 (the "License");
# you may not use this file except in compliance with the License.
# You may obtain a copy of the License at
#
#     http://www.apache.org/licenses/LICENSE-2.0
#
# Unless required by applicable law or agreed to in writing, software
# distributed under the License is distributed on an "AS IS" BASIS,
# WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
# See the License for the specific language governing permissions and
# limitations under the License.
#
# %CopyrightEnd%
#
use strict;
use vars qw($BEAM_FORMAT_NUMBER $GC_REGEXP);
use constant COLD => 0;
use constant WARM => 1;
use constant HOT => 2;
use constant JIT => 3;

# Instructions for packing
use constant PACK_JUMP => 1;
use constant PACK_IN_INSTR_WORD => 2;
use constant PACK_OPT_IN_INSTR_WORD => 4;

# Packing commands
use constant PACK_CMD_TIGHTEST => '1';
use constant PACK_CMD_TIGHT => '2';
use constant PACK_CMD_LOOSE => '3';
use constant PACK_CMD_WIDE => '4';

$BEAM_FORMAT_NUMBER = undef;
$GC_REGEXP = undef;

my $target = \&emulator_output;
my $outdir = ".";		# Directory for output files.
my $verbose = 0;
my $hotness = 1;
my $num_file_opcodes = 0;
my $wordsize = 32;
my $code_pointers_are_short = 0; # Whether code pointers (to C code) are short.
my $code_model = 'unknown';
my $jit = 'no';
my %defs;                        # Defines (from command line).
my $pending_errors = 0;          # Number of pending errors.

# Intentionally unused macros, predicates, and generators.
my %intentionally_unused;

# This is shift counts and mask for the packer.
my $WHOLE_WORD = '';

my @basic_pack_options = (0);
my @extended_pack_options = @basic_pack_options;

# There are two types of instructions: generic and specific.
# The generic instructions are those generated by the Beam compiler.
# Corresponding to each generic instruction, there is generally a
# whole family of related specific instructions. Specific instructions
# are those executed by the VM interpreter during run-time.

# Maximum number of operands for a generic instruction.
# In beam_load.c the ERTS_BEAM_MAX_OPARGS refers to the maximum
# number of operands for generic instructions.
my $max_gen_operands = 8;

# Maximum number of operands for a generic instruction that has more than
# one associated specific instruction. This limit does not apply if there
# is only a single associated specific instruction.
#
# This value must be even. If it is ever to be changed, erl_vm.h and
# beam_load.c file must be updated.
my $max_spec_operands = 6;

# The maximum number of primitive genop_types.

my $max_genop_types = 16;

my %gen_opnum;
my %num_specific;
my %gen_to_spec;
my %specific_op;

# The following hashes are used for error checking.
my %print_name;
my %specific_op_arity;

# Information about each specific operator. Key is the print name (e.g. get_list_xxy).
# Value is a hash.
my %spec_op_info;

my %gen_arity;
my @gen_arity;

my @gen_opname;
my @op_to_name;

my @obsolete;

# Instructions and micro instructions implemented in C.
my %c_code;                     # C code block, location, arguments.
my %c_code_used;                # Used or not.
my %c_param_types;              # Types for predicates and generators.

# Definitions for instructions combined from micro instructions.
my %combined_instrs;

my @generated_code;             # Generated code.
my %sort_order;

my @unnumbered_generic;
my %unnumbered;

my %is_transformed;

#
# Pre-processor.
#
my @if_val;
my @if_line;

#
# Code transformations.
#
my $te_max_vars = 0;		# Max number of variables ever needed.
my %gen_transform;
my @transformations;

# Operand types for generic instructions.

my $compiler_types = "uiaxyfhz";
my $loader_types = "nprvlqo";
my $genop_types = $compiler_types . $loader_types;

#
# Define the operand types for specific instructions and their loaded
# size assuming no packing.
#
# These are the types that can be used in the definition of a specific
# instruction. Note that there may be more types depending on which emulator is
# being built, for example the 'r' type in beam_emu, which are filled in later
# on.
#
# Note that the 'i' type is NOT defined, because it does not make
# sense; instructions that accept small operands invariably also accept other
# literals.
#
my %arg_size = ('r' => 0,	# x(0) - x register zero,
		'x' => 1,	# x(N), N > 0 - x register
		'y' => 1,	# y(N) - y register
		'a' => 1,	# tagged atom
		'n' => 0,	# NIL (implicit)
		'c' => 1,	# tagged constant (integer, atom, nil, other literals)
		's' => 1,	# tagged source; any of the above
                'S' => 1,       # tagged source register (x or y)
		'd' => 1,	# tagged destination register (r, x, y)
		'f' => 1,	# failure label
		'j' => 1,	# either 'f' or 'p'
		'e' => 1,	# pointer to export entry
		'L' => 0,	# label
		't' => 1,	# untagged integer (12 bits) -- can be packed
		'I' => 1,	# untagged integer (32 bits) -- can be packed
                'W' => 1,       # untagged integer/pointer (one word)
		'b' => 1,	# pointer to bif
		'F' => 1,	# pointer to function entry
		'A' => 1,	# arity value
		'P' => 1,	# byte offset into tuple or stack
		'Q' => 1,	# like 'P', but packable
		'h' => 1,	# character (not used)
		'l' => 1,	# float reg
		'q' => 1,	# literal term
		'M' => 1,	# pointer to raw string
		'H' => 1,	# exception handler
	     );

# Maps operand type to the argument classes used by the JIT.
my %arg_jit_class = ('r' => 'ArgXRegister',
                     'x' => 'ArgXRegister',
                     'y' => 'ArgYRegister',
                     'a' => 'ArgAtom',
                     'n' => 'ArgNil',
                     'c' => 'ArgConstant',
                     's' => 'ArgSource',
                     'S' => 'ArgRegister',
                     'd' => 'ArgRegister',
                     'f' => 'ArgLabel',
                     'j' => 'ArgLabel',
                     'e' => 'ArgExport',
                     'L' => 'ArgLabel',
                     't' => 'ArgWord',
                     'I' => 'ArgWord',
                     'W' => 'ArgWord',
                     'b' => 'ArgWord',
                     'F' => 'ArgLambda',
                     'A' => 'ArgWord',
                     'P' => 'ArgWord',
                     'Q' => 'ArgWord',
                     'h' => 'ArgWord',
                     'l' => 'ArgFRegister',
                     'q' => 'ArgLiteral',
                     'M' => 'ArgBytePtr',
                     'H' => 'ArgCatch',
                    );

# Define a lattice for the parameter classes used in the JIT.
#
# The classes are represented as a bitset where each class is represented by
# a single bit, which is combined with that of its superclasses, letting us
# find the best superclass for a given set of classes by AND-ing them together.
my %arg_jit_lattice;
{
    # Perl lacks enums, lovely :(
    my $iota = 0;
    my %jcl;

    $jcl{'ArgVal'} = (1 << $iota++),

    $jcl{'ArgBytePtr'} = $jcl{'ArgVal'} | (1 << $iota++);
    $jcl{'ArgCatch'} = $jcl{'ArgVal'} | (1 << $iota++);
    $jcl{'ArgExport'} = $jcl{'ArgVal'} | (1 << $iota++);
    $jcl{'ArgLabel'} = $jcl{'ArgVal'} | (1 << $iota++);
    $jcl{'ArgLambda'} = $jcl{'ArgVal'} | (1 << $iota++);
    $jcl{'ArgSource'} = $jcl{'ArgVal'} | (1 << $iota++);
    $jcl{'ArgWord'} = $jcl{'ArgVal'} | (1 << $iota++);

    $jcl{'ArgConstant'} = $jcl{'ArgSource'} | (1 << $iota++);
    $jcl{'ArgRegister'} = $jcl{'ArgSource'} | (1 << $iota++);

    $jcl{'ArgLiteral'} = $jcl{'ArgConstant'} | (1 << $iota++);
    $jcl{'ArgImmed'} = $jcl{'ArgConstant'} | (1 << $iota++);

    $jcl{'ArgAtom'} = $jcl{'ArgImmed'} | (1 << $iota++);
    $jcl{'ArgNil'} = $jcl{'ArgImmed'} | (1 << $iota++);
    $jcl{'ArgSmall'} = $jcl{'ArgImmed'} | (1 << $iota++);

    $jcl{'ArgXRegister'} = $jcl{'ArgRegister'} | (1 << $iota++);
    $jcl{'ArgYRegister'} = $jcl{'ArgRegister'} | (1 << $iota++);
    $jcl{'ArgFRegister'} = $jcl{'ArgRegister'} | (1 << $iota++);

    foreach my $class (keys %jcl) {
        my $bits = $jcl{$class};
        $jcl{$bits} = $class;
    }

    %arg_jit_lattice = %jcl;
}

#
# Types that are forbidden to use for specific operations.
#

my %forbidden_type;

#
# Define the types that may be used in a transformation rule.
#
# %pattern_type defines the types that may be used in a pattern
# on the left side.
#
# %construction_type defines the types that may be used when
# constructing a new instruction on the right side (a subset of
# the pattern types that are possible to construct).
#
my $pattern_types = "acdfjilnopqsuxy";
my %pattern_type;
@pattern_type{split("", $pattern_types)} = (1) x length($pattern_types);

my %construction_type;
foreach my $type (keys %pattern_type) {
    $construction_type{$type} = 1
        if index($genop_types, $type) >= 0;
}
foreach my $makes_no_sense ('f', 'j', 'o', 'q') {
    delete $construction_type{$makes_no_sense};
}

#
# Generate bits.
#
my %type_bit;
my @tag_type;

sub define_type_bit {
    my($tag,$val) = @_;
    defined $type_bit{$tag} and
	sanity("the tag '$tag' has already been defined with the value ",
	       $type_bit{$tag});
    $type_bit{$tag} = $val;
}

{
    my($bit) = 1;
    my(%bit);

    foreach (split('', $genop_types)) {
	push(@tag_type, $_);
	define_type_bit($_, $bit);
	$bit{$_} = $bit;
	$bit *= 2;
    }

    # Composed types.
    define_type_bit('d', $type_bit{'x'} | $type_bit{'y'});
    define_type_bit('c', $type_bit{'i'} | $type_bit{'a'} |
		    $type_bit{'n'} | $type_bit{'q'});
    define_type_bit('s', $type_bit{'d'} | $type_bit{'i'} |
		    $type_bit{'a'} | $type_bit{'n'} |
		    $type_bit{'q'});
    define_type_bit('S', $type_bit{'d'});
    define_type_bit('j', $type_bit{'f'} | $type_bit{'p'});

    # Aliases of 'u'.  Those specify how to load the operand and
    # what kind of packing can be done.
    define_type_bit('t', $type_bit{'u'});
    define_type_bit('I', $type_bit{'u'});
    define_type_bit('W', $type_bit{'u'});
    define_type_bit('A', $type_bit{'u'});
    define_type_bit('L', $type_bit{'u'});
    define_type_bit('b', $type_bit{'u'});
    define_type_bit('F', $type_bit{'u'});
    define_type_bit('e', $type_bit{'u'});
    define_type_bit('Q', $type_bit{'u'});
    define_type_bit('P', $type_bit{'u'});
    define_type_bit('M', $type_bit{'u'});
    define_type_bit('H', $type_bit{'u'});
}

#
# Sanity checks.
#

{
    if (@tag_type > $max_genop_types) {
	sanity("\$max_genop_types is $max_genop_types, ",
	       "but there are ", scalar(@tag_type),
	       " primitive tags defined\n");
    }

    foreach my $tag (@tag_type) {
	sanity("tag '$tag': primitive tags must be named with lowercase letters")
	    unless $tag =~ /^[a-z]$/;
    }

    foreach my $tag (keys %arg_size) {
        defined $type_bit{$tag} or
            sanity("the tag '$tag' has a size in %arg_size, " .
                   "but has no defined bit pattern");
    }
}

#
# Parse command line options.
#

while (@ARGV && $ARGV[0] =~ /^-(.*)/) {
    $_ = $1;
    shift;
    ($target = \&emulator_output), next if /^emulator/;
    ($target = \&compiler_output), next if /^compiler/;
    ($outdir = shift), next if /^outdir/;
    ($wordsize = shift), next if /^wordsize/;
    ($code_model = shift), next if /^code-model/;
    ($verbose = 1), next if /^v/;
    ($jit = shift), next if /^jit/;
    ($defs{$1} = $2), next if /^D(\w+)=(\w+)/;
    die "$0: Bad option: -$_\n";
}


if ($wordsize == 32) {
    $defs{'ARCH_32'} = 1;
    $defs{'ARCH_64'} = 0;
} elsif ($wordsize == 64) {
    $defs{'ARCH_32'} = 0;
    $defs{'ARCH_64'} = 1;
    $code_pointers_are_short = $code_model eq 'small';
}

#
# Initialize pack options.
#

if ($wordsize == 64) {
    @basic_pack_options = (0,PACK_JUMP);
    @extended_pack_options = @basic_pack_options;
    if ($code_pointers_are_short) {
        foreach (@basic_pack_options) {
            push @extended_pack_options, $_ | PACK_IN_INSTR_WORD;
        }
    }
}

#
# Add placeholders for built-in macros.
#

my %predef_macros =
    (OPERAND_POSITION => ['Expr'],
     IF => ['Expr','IfTrue','IfFalse'],
     REFRESH_GEN_DEST => [],
    );
foreach my $name (keys %predef_macros) {
    my @args = @{$predef_macros{$name}};
    my $body = join(':', map { '$' . $_ } @args);
    $c_code{$name} = [$body,"built-in macro",@args],
    $c_code_used{$name} = 1;
}

#
# Parse the input files.
#

my $in_c_code = '';
my $c_code_block;
my $c_code_loc;
my @c_args;

while (<>) {
    my($op_num);
    if ($in_c_code) {
        if (/^\}/) {
            my $name = $in_c_code;
            my $block = $c_code_block;
            $in_c_code = '';
            $block =~ s/^    //mg;
            chomp $block;
	    $c_code{$name} = [$block,$c_code_loc,@c_args];
        } else {
            $c_code_block .= $_;
        }
        next;
    }
    chomp;
    if (s/\\$//) {
        error("line continuation with `\\` is no longer allowed");
    } elsif (/([|]|=>)$/) {
        # Automatically continue a line that ends in '|' or '=>'.
        my $next_line = <>;
        $_ .= $next_line;
        chomp $next_line;
        redo unless eof(ARGV) or $next_line eq '';
    }
    next if /^\s*$/;
    next if /^\#/;
    next if m@^//@;

    #
    # Handle %if.
    #
    if (/^\%if (\w+)/) {
	my $name = $1;
	my $val = $defs{$name};
	defined $val or error("'$name' is undefined");
	push @if_val, $val;
	push @if_line, $.;
	next;
    } elsif (/^\%unless (\w+)/) {
	my $name = $1;
	my $val = $defs{$name};
	defined $val or error("'$name' is undefined");
	push @if_val, !$val;
	push @if_line, $.;
	next;
    } elsif (/^\%else$/) {
	unless (@if_line) {
	    error("%else without a preceding %if/%unless");
	}
	$if_line[$#if_line] = $.;
	$if_val[$#if_val] = !$if_val[$#if_val];
	next;
    } elsif (/^\%endif$/) {
	unless (@if_line) {
	    error("%endif without a preceding %if/%unless/%else");
	}
	pop @if_val;
	pop @if_line;
	next;
    }
    if (@if_val and not $if_val[$#if_val]) {
	next;
    }

    #
    # Handle assignments.
    #
    if (/^([\w_][\w\d_]+)=(.*)/) {
	my $name = $1;
        my $value = $2;
	$value =~ s/;\s*$//;
	if ($name eq 'FORBIDDEN_TYPES') {
	    for my $type (split('', $value)) {
		error("'$type' is not a recognized type")
		    unless defined $arg_size{$type};
		$forbidden_type{$type} = 1;
	    }
	} else {
	    no strict 'refs';
	    $$name = $value;
	}
	next;
    }

    #
    # Handle %hot, %warm, and %cold.
    # 
    if (/^\%hot/) {
	$hotness = HOT;
	next;
    } elsif (/^\%warm/) {
	$hotness = WARM;
        next;
    } elsif (/^\%cold/) {
	$hotness = COLD;
	next;
    }

    #
    # Handle %unused.
    #
    if (/^\%unused\s+(\S+)/) {
        my $name = $1;
        error("Illegal predicate/generator name '$name'")
            unless $name =~ /^[a-z][.\w\d_]*$/;
        $intentionally_unused{$name} = 1;
        next;
    }

    #
    # Handle unrecognized % directives.
    #
    if (/^\%(\S+)/) {
        error("Unrecognized directive '%$1'");
    }

    #
    # Handle transformations.
    #
    if (/=>/) {
	parse_transformation($_);
	next;
    }

    #
    # Handle C code blocks.
    #
    if (/^(\w[\w.]*)\(([^\)]*)\)\s*{/) {
        my $name = $1;
        $in_c_code = $name;
        $c_code_block = '';
        @c_args = parse_c_args($2);
        $c_code_loc = "$ARGV($.)";
        if (defined $c_code{$name}) {
            my $where = $c_code{$name}->[1];
            error("$name: already defined at $where");
        }
        next;
    }

    #
    # Handle definition of instructions in terms of
    # micro instructions.
    #
    if (/^(\w+)\s*:=\s*([\w.]+)\s*;\s*$/) {
        $combined_instrs{$1} = ["$ARGV($.)",$2];
        next;
    }

    #
    # Parse off the number of the operation.
    #
    $op_num = undef;
    if (s/^(\d+):\s*//) {
	$op_num = $1;
	$op_num != 0 or error("Opcode 0 invalid");
	error("Opcode $op_num already defined")
	    if defined $gen_opname[$op_num];
    }

    #
    # Parse: Name/Arity  (generic instruction)
    #
    if (m@^(-)?(\w+)/(\d)\s*$@) {
	my($obsolete) = $1;
	my($name) = $2;
	my($arity) = $3;
	$name =~ /^[a-z]/ or error("Opname must start with a lowercase letter");
	defined $gen_arity{$name} and $gen_arity{$name} != $arity and
	    error("Opname $name already defined with arity $gen_arity{$name}");
	defined $unnumbered{$name,$arity} and
	    error("Opname $name already defined with arity $gen_arity{$name}");
	
	if (defined $op_num) {	# Numbered generic operation
	    $gen_opname[$op_num] = $name;
	    $gen_arity[$op_num] = $arity;
	    $gen_opnum{$name,$arity} = $op_num;
	    $gen_arity{$name} = $arity;
	    $gen_to_spec{"$name/$arity"} = undef;
	    $num_specific{"$name/$arity"} = 0;
	    $obsolete[$op_num] = defined $obsolete;
	} else {		# Unnumbered generic operation.
	    push(@unnumbered_generic, [$name, $arity]);
	    $unnumbered{$name,$arity} = 1;
	}
	next;
    }

    #
    # Parse specific instructions (only present in emulator/loader):
    #    Name Arg1 Arg2...
    #
    my($name,$arity) = parse_specific_op($_);
    if (defined $op_num) {
	error("specific instructions must not be numbered");
    } elsif (!defined($gen_arity{$name}) && !defined($unnumbered{$name,$arity})) {
	#
	# Create an unumbered generic instruction too.
	#
	push(@unnumbered_generic, [$name, $arity]);
	$unnumbered{$name,$arity} = 1;
    }
} continue {
    if (eof(ARGV)) {
	close(ARGV);
	if (@if_line) {
	    error("Unterminated %if/%unless/%else at " .
		  "line $if_line[$#if_line]\n");
	}
    }
}

$num_file_opcodes = @gen_opname;

#
# Number all generic operations without numbers.
#
{
    my $ref;

    foreach $ref (@unnumbered_generic) {
	my($name, $arity) = @$ref;
	my $op_num = @gen_opname;
	push(@gen_opname, $name);
	push(@gen_arity, $arity);
	$gen_opnum{$name,$arity} = $op_num;
	$gen_arity{$name} = $arity;
	$gen_to_spec{"$name/$arity"} = undef;
	$num_specific{"$name/$arity"} = 0;
    }
}

#
# Now verify that specific instructions don't have too many operands
# or use forbidden types.
#

foreach my $key (keys %specific_op) {
    my($arity) = (split('/', $key))[1];
    my @specific_ops = @{$specific_op{$key}};
    my $num_specific_ops = scalar(@{$specific_op{$key}});
    if ($arity > $max_spec_operands and $num_specific_ops > 1) {
	my($first) = @specific_ops;
	my $name = $first->[0];
	my $loc = $specific_op_arity{$name}->[1];
	my $error = join("\n*** ",
			 "$loc: too many operands",
			 "When a generic instruction has more than one associated specific instruction,",
			 "it must not have more than $max_spec_operands operands.",
			 "",
			 "$key has $num_specific_ops specific instructions.");
	$error .= "\n";
	error($error);
    }

    foreach my $op (@specific_ops) {
	my($name, $hotness, $varargs, @args) = @$op;
	for my $arg (@args) {
	    my $cleaned_arg = $arg;
	    $cleaned_arg =~ s/[?]$//;
	    if ($jit ne 'no' and $cleaned_arg eq 'r') {
                pending_error("specific instruction '$name @args' uses type " .
                              "'r' which is is not supported for BeamAsm");
	    } elsif ($forbidden_type{$cleaned_arg}) {
		pending_error("specific instruction '$name @args' uses " .
                              "forbidden type '$arg'\n");
	    }
	}
    }
}

error("beam_makeops: terminating because there were previous errors")
    if $pending_errors > 0;

#
# Produce output for the chosen target.
#

&$target();

error("beam_makeops: terminating because there were previous errors")
    if $pending_errors > 0;

#
# Ensure that all C code implementations have been used.
#
{
    my(@unused) = grep(!$c_code_used{$_}, keys %c_code);
    @unused = grep(!$intentionally_unused{$_}, @unused);
    foreach my $unused (sort @unused) {
        my(undef,$where) = @{$c_code{$unused}};
        warn "$where: $unused is unused\n";
    }
    die "\n" if @unused;
}

#
# Produce output needed by the emulator/loader.
#

sub emulator_output {
    my $i;
    my $name;
    my $key;			# Loop variable.

    foreach $key (sort keys %c_code) {
        if ($intentionally_unused{$key}) {
            delete $c_code{$key};
        }
#        print STDERR "$key: ", defined($c_code{$key}), "\n";
    }

    # Initialize common information always needed.
    foreach $key (keys %specific_op) {
	foreach (@{$specific_op{$key}}) {
	    my($name, $hotness, $varargs, @args) = @$_;
	    my $print_name = print_name($name, @args);
            my %info = ('args' => \@args);
            $spec_op_info{$print_name} = \%info;
	}
    }

    if ($jit eq 'no') {
	#
	# Generate code and meta information for all instructions.
	#
	foreach $key (keys %specific_op) {
	    foreach (@{$specific_op{$key}}) {
		my($name, $hotness, $varargs, @args) = @$_;
		my $print_name = print_name($name, @args);
		my $pack_spec = '';
		my $size = 0;

		($size, my $code, $pack_spec) = cg_basic(name => $name, args => \@args);
		if (defined $code) {
		    $code = "OpCase($print_name):\n$code";
		    push @generated_code, [$hotness,$code,($print_name)];
		}

		# Note: Some of the information below will be modified
		# for combined instructions.
		my %info = ('size' => $size,
			    'pack_spec' => $pack_spec,
			    'adj' => 0,
			    'args' => \@args);
		$spec_op_info{$print_name} = \%info;
	    }
	}

	#
	# Combine micro instruction into instruction blocks and generate
	# code for them.
	#
        combine_micro_instructions();
    } elsif ($jit eq 'yes') {
	#
	# Generate the code for the BeamAsm glue files.
	#
        foreach $key (keys %specific_op) {
            foreach (@{$specific_op{$key}}) {
                my($name, $hotness, $varargs, @args) = @$_;
                my $print_name = print_name($name, @args);
                my $body = "emit_$name(";
		my $sep = "";

		for (my $i = 0; $i < @args; $i++) {
                    $body .= "${sep}args[$i]";
		    $sep = ", ";
                }

		if ($varargs) {
		    # We pass variable argument lists as a Span of ArgVal,
		    # slicing our argument vector after the argument count.
		    $body .= $sep .
			"args.subspan(" . scalar(@args) . "," .
				      "args.size() - " . scalar(@args) . ")";
		}

                $body .= ");";
                push @generated_code, [JIT,"case op_$print_name: {\n$body\n\tbreak;\n}\n\n",($print_name)];
            }
        }

        $name = "$outdir/beamasm_emit.h";
        open(STDOUT, ">$name") || die "Failed to open $name for writing: $!\n";
        comment('C');
        print_code(JIT);

        $name = "$outdir/beamasm_protos.h";
        open(STDOUT, ">$name") || die "Failed to open $name for writing: $!\n";
        comment('C');

        # Sort the generated code to create beamasm_protos.h deterministically
        foreach $key (sort keys %specific_op) {
            my @specific_ops = @{$specific_op{$key}};
            my ($name,
                $hotness,
                $varargs,
                @combined_signs) = @{shift @specific_ops};

            # We want to reduce all specific ops to the same prototype, so
            # their signs must be combined to find the right argument types.
            foreach (@specific_ops) {
                my (undef, undef, undef, @specific_signs) = @$_;

                for my $i (0..$#combined_signs) {
                    $combined_signs[$i] .= $specific_signs[$i];
                }
            }

            my @typed_args;
            for my $signs (@combined_signs) {
                my $class = get_jit_class($signs);
                push @typed_args, "const $class&";
            }

            if ($varargs) {
                push @typed_args, "const Span<ArgVal>&";
            }

            print "void emit_$name(", join(", ", @typed_args), ");\n";
        }
    }

    #
    # Information about opcodes (beam_opcodes.c).
    #
    $name = "$outdir/beam_opcodes.c";
    open(STDOUT, ">$name") || die "Failed to open $name for writing: $!\n";
    comment('C');
    include_files();
    print '#include "erl_term.h"', "\n";
    print '#include "erl_map.h"', "\n";
    print '#include "big.h"', "\n";
    print '#include "erl_bits.h"', "\n";
    print '#include "erl_binary.h"', "\n";
    print '#include "beam_transform_helpers.h"', "\n";
    print '#include "erl_global_literals.h"', "\n";
    print '#include "erl_debugger.h"', "\n";
    print "\n";

    print "const char tag_to_letter[] = {\n  ";
    for ($i = 0; $i < length($genop_types); $i++) {
	print "'$tag_type[$i]', ";
    }
    for (; $i < @tag_type; $i++) {
	print "'_', ";
    }
    print "\n};\n";
    print "\n";

    #
    # Generate code for specific ops.
    #
    my $spec_opnum = 0;
    print "const OpEntry opc[] = {\n";
    foreach $key (sort keys %specific_op) {
	$gen_to_spec{$key} = $spec_opnum;
	$num_specific{$key} = @{$specific_op{$key}};

	#
	# Pick up all instructions and manufacture sort keys; we must have
	# the most specific instructions appearing first (e.g. an 'x' operand
	# should be matched before 's' or 'd').
	#
	my(%items) = ();
	foreach (@{$specific_op{$key}}) {
	    my($name, $hotness, $varargs, @args) = @{$_};
	    my($sign) = join('', @args);
            $sign =~ s/[?]//g;

	    # The primitive types should sort before other types.

	    my $sort_key = $sign;
	    eval "\$sort_key =~ tr/$genop_types/./";
	    $sort_key .= ":$sign";
            my $print_name = print_name($name, @args);
	    $items{$sort_key} = $print_name;
	}

	#
	# Now call the generator for the sorted result.
	#
	foreach my $sort_key (sort keys %items) {
            my $print_name = $items{$sort_key};
            my $info = $spec_op_info{$print_name};
            my(@args) = @{$info->{'args'}};
            @args = map { s/[?]$//; $_ } @args;
	    my $arity = @args;

	    #
	    # Calculate the bit mask which should be used to match this
	    # instruction.
	    #

	    my(@bits) = (0) x ($max_spec_operands/2);
	    my($i);
	    my $involves_r = 0;
	    for ($i = 0; $i < $max_spec_operands && defined $args[$i]; $i++) {
		my $t = $args[$i];
		my $bits = $type_bit{$t};
		if ($t eq 'r') {
		    $bits |= $type_bit{'x'};
		    $involves_r |= 1 << $i;
		}
		my $shift = $max_genop_types * ($i % 2);
		$bits[int($i/2)] |= $bits << $shift;
	    }

	    printf "/* %3d */  ", $spec_opnum;

	    # If there is only one specific instruction, output a dummy mask
	    # to make it clear for human readers that there is only one.
	    # The mask will not be used by the loader.
	    my $init = "{0,0,0}";
	    if ($num_specific{$key} > 1) {
		$init = "{";
		my $sep = "";
		foreach (@bits) {
		    $init .= sprintf("%s0x%X", $sep, $_);
		    $sep = ",";
		}
		$init .= "}";
	    }
            my $adj = $info->{'adj'};
            my $size = $info->{'size'};
            my $pack_spec = $info->{'pack_spec'};
            my $sign = join '', @args;
	    if ($jit eq 'no') {
		init_item($print_name, $init, $involves_r, $size, $adj, $pack_spec, $sign);
	    } else {
		init_item($print_name, $init, $sign);
	    }
	    $op_to_name[$spec_opnum] = $print_name;
	    $spec_opnum++;
	}
    }
    print "};\n\n";
    print "const int num_instructions = $spec_opnum;\n\n";

    #
    # Print the array for instruction counts.
    #

    print "#ifdef ERTS_OPCODE_COUNTER_SUPPORT\n";
    print "Uint erts_instr_count[$spec_opnum];\n";
    print "#endif\n";
    print "\n";

    #
    # Generate transformations.
    #

    tr_gen(@transformations);

    #
    # Print the generic instruction table.
    #

    print "const GenOpEntry gen_opc[] = {\n";
    for ($i = 0; $i < @gen_opname; $i++) {
	if ($i == $num_file_opcodes) {
            print starred_comment("Internal generic instructions.");
	}
	my($name) = $gen_opname[$i];
	my($arity) = $gen_arity[$i];
	printf "/* %3d */  ", $i;
	if (!defined $name) {
	    init_item("", 0, 0, 0, 0);
	} else {
	    my($key) = "$name/$arity";
	    my($tr) = defined $gen_transform{$key} ? 1 : 0;
	    my($spec_op) = $gen_to_spec{$key};
	    my($num_specific) = $num_specific{$key};
	    defined $spec_op or
		$obsolete[$gen_opnum{$name,$arity}] or
		$is_transformed{$name,$arity} or
		error("instruction $key has no specific instruction");
	    $spec_op = -1 unless defined $spec_op;
	    init_item($name, $arity, $spec_op, $num_specific, $tr);
	}
    }
    print "};\n";

    #
    # Information about opcodes (beam_opcodes.h).
    #
    $name = "$outdir/beam_opcodes.h";
    open(STDOUT, ">$name") || die "Failed to open $name for writing: $!\n";
    comment('C');
    print "#ifndef __OPCODES_H__\n";
    print "#define __OPCODES_H__\n\n";

    print "#define BEAM_FORMAT_NUMBER $BEAM_FORMAT_NUMBER\n";
    print "#define MAX_GENERIC_OPCODE ", $num_file_opcodes-1, "\n";
    print "#define NUM_GENERIC_OPS ", scalar(@gen_opname), "\n";
    print "#define NUM_SPECIFIC_OPS ", scalar(@op_to_name), "\n";
    print "#define SCRATCH_X_REG 1023\n";
    print "\n";
    if ($wordsize == 32) {
	print "#if defined(ARCH_64)\n";
	print qq[  #error "32-bit architecture assumed, but ARCH_64 is defined"\n];
	print "#endif\n";
	print "#define BEAM_LOOSE_MASK 0xFFF\n";
	print "#define BEAM_TIGHT_MASK 0xFFC\n";
	print "#define BEAM_LOOSE_SHIFT 16\n";
	print "#define BEAM_TIGHT_SHIFT 10\n";
    } elsif ($wordsize == 64) {
	print "#if !defined(ARCH_64)\n";
	print qq[  #error "64-bit architecture assumed, but ARCH_64 not defined"\n];
	print "#endif\n";
        if ($code_pointers_are_short) {
            print "#if !defined(CODE_MODEL_SMALL)\n";
            print qq[  #error "small code model assumed, but CODE_MODEL_SMALL not defined"\n];
            print "#endif\n";
        }
	print "#define BEAM_WIDE_MASK 0xFFFFFFFFull\n";
	print "#define BEAM_LOOSE_MASK 0xFFFFull\n";
	print "#define BEAM_TIGHT_MASK 0xFFFFull\n";
	print "#define BEAM_TIGHTEST_MASK 0x3FFull\n";
	print "#define BEAM_WIDE_SHIFT 32\n";
	print "#define BEAM_LOOSE_SHIFT 16\n";
	print "#define BEAM_TIGHT_SHIFT 16\n";
	print "#define BEAM_TIGHTEST_SHIFT 10\n";
    }
    print "\n";

    #
    # Definitions of tags.
    #

    my $letter;
    my $tag_num = 0;

    comment('C', "The following operand types for generic instructions",
	     "occur in beam files.");
    foreach $letter (split('', $compiler_types)) {
	print "#define TAG_$letter $tag_num\n";
	$tag_num++;
    }
    print "\n";
    comment('C', "The following operand types are only used in the loader.");
    foreach $letter (split('', $loader_types)) {
	print "#define TAG_$letter $tag_num\n";
	$tag_num++;
    }
    print "\n#define BEAM_NUM_TAGS $tag_num\n\n";

    print "extern const char tag_to_letter[];\n";
    print "extern const Uint op_transform[];\n";
    print "\n";

    for ($i = 0; $i < @op_to_name; $i++) {
	print "#define op_$op_to_name[$i] $i\n";
    }
    print "\n";

    print "#define NUMBER_OF_OPCODES ",scalar(@op_to_name),"\n";
    for ($i = 0; $i < @op_to_name; $i++) {
	print "#define op_count_$op_to_name[$i] ",$i+scalar(@op_to_name),"\n";
    }
    print "\n";

    print "#define DEFINE_OPCODES";
    foreach (@op_to_name) {
	print " \\\n&&lb_$_,";
    }
    print "\n\n";

    print "#define DEFINE_COUNTING_OPCODES";
    foreach (@op_to_name) {
	print " \\\n&&lb_count_$_,";
    }
    print "\n\n";

    print "#define DEFINE_COUNTING_LABELS";
    for ($i = 0; $i < @op_to_name; $i++) {
	my($name) = $op_to_name[$i];
	print " \\\nCountCase($name): erts_instr_count[$i]++; goto lb_$name;";
    }
    print "\n\n";

    for ($i = 0; $i < @gen_opname; $i++) {
	print "#define genop_$gen_opname[$i]_$gen_arity[$i] $i\n"
	    if defined $gen_opname[$i];
    }


    print "#endif\n";

    #
    # Implementation of operations for emulator.
    #
    if ($jit eq 'no') {
	$name = "$outdir/beam_hot.h";
	open(STDOUT, ">$name") || die "Failed to open $name for writing: $!\n";
	comment('C');
	print_code(HOT);

	$name = "$outdir/beam_warm.h";
	open(STDOUT, ">$name") || die "Failed to open $name for writing: $!\n";
	comment('C');
	print_code(WARM);

	$name = "$outdir/beam_cold.h";
	open(STDOUT, ">$name") || die "Failed to open $name for writing: $!\n";
	comment('C');
	print_code(COLD);
    }
}

sub print_name {
    my($name,@args) = @_;
    my $sign = join '', @args;
    $sign =~ s/[?]//g;
    $sign ne '' ? "${name}_$sign" : $name;
}

sub init_item {
    my($sep) = "";

    print "{";
    foreach (@_) {
	if (!defined $_) {
	    print "${sep}NULL";
	} elsif (/^\{/) {
	    print "$sep$_";
	} elsif (/^-?\d+$/) {
	    print "$sep$_";
	} else {
	    print "$sep\"$_\"";
	}
	$sep = ", ";
    }
    print "},\n";
}

sub q {
    my($str) = @_;
    "\"$str\"";
}

sub print_code {
    my($include_hot) = @_;
    my %sorted;

    foreach my $ref (@generated_code) {
        my($hot,$code,@labels) = @$ref;
        next unless $hot == $include_hot;
        my($sort_key) = @labels; # Use the first label as sort key.
        $sorted{$sort_key} = $code;
    }

    foreach (sort keys %sorted) {
	print_indented_code($sorted{$_});
    }
}

sub print_indented_code {
    my(@code) = @_;

    foreach my $chunk (@code) {
        my $indent = 0;
        foreach (split "\n", $chunk) {
            s/^\s*//;
            if (/\}/) {
                $indent -= 2;
            }
            if ($_ eq '') {
                print "\n";
            } elsif (/^#/) {
                print $_, "\n";
            } else {
                print ' ' x $indent, $_, "\n";
            }
            if (/\{/) {
                $indent += 2;
            }
        }
        print "\n";
    }
}


#
# Produce output needed by the compiler back-end (assembler).
#

sub compiler_output {
    my($module) = 'beam_opcodes';
    my($name) = "${module}.erl";
    my($i);

    open(STDOUT, ">$outdir/$name") || die "Failed to open $name for writing: $!\n";
    print "-module($module).\n-moduledoc false.";
    comment('erlang');

    print "-export([format_number/0]).\n";
    print "-export([opcode/2,opname/1]).\n";
    print "\n";
    print "-spec format_number() -> $BEAM_FORMAT_NUMBER.\n";
    print "format_number() -> $BEAM_FORMAT_NUMBER.\n\n";

    print "-spec opcode(atom(), 0..", $max_gen_operands, ") -> 1..", $num_file_opcodes-1, ".\n";
    for ($i = 0; $i < @gen_opname; $i++) {
	next unless defined $gen_opname[$i];
	print "%%" if $obsolete[$i];
	print "opcode(", quote($gen_opname[$i]), ", $gen_arity[$i]) -> $i;\n";
    }
    print "opcode(Name, Arity) -> erlang:error(badarg, [Name,Arity]).\n\n";

    print "-spec opname(1..", $num_file_opcodes-1, ") -> {atom(),0..", $max_gen_operands, "}.\n";
    for ($i = 0; $i < @gen_opname; $i++) {
	next unless defined $gen_opname[$i];
	print "opname($i) -> {",
	quote($gen_opname[$i]), ",$gen_arity[$i]};\n";
    }
    print "opname(Number) -> erlang:error(badarg, [Number]).\n";

    #
    # Generate .hrl file.
    #
    my($hrl_name) = "$outdir/${module}.hrl";
    open(STDOUT, ">$hrl_name") || die "Failed to open $hrl_name for writing: $!\n";
    comment('erlang');

    for ($i = 0; $i < @tag_type && $i < 8; $i++) {
	print "-define(tag_$tag_type[$i], $i).\n";
    }
    print "\n";

}

#
# Parse and store a specific operation.
#
sub parse_specific_op {
    my($name, @args) = split " ", shift;
    my $arity = @args;
    my $varargs = 0;

    # Check for various errors.
    error("Bad opcode name '$name'")
	unless $name =~ /^[a-z][\w\d_]*$/;
    for (my $i = 0; $i < $arity; $i++) {
        my $arg = $args[$i];
	if ($arg eq '*') {
	    $i == $arity - 1 or error("'*' must be the last operand");
	    pop @args;
	    $arity--;
	    $varargs = 1;
	    last;
	}
        $arg =~ s/[?]$//;
        foreach my $type (split(//, $arg)) {
	    if ($type eq 'i') {
		error("Argument " . ($i+1) . ": the 'i' type is not supported in specific instructions (use 'c')")
	    }
            error("Argument " . ($i+1) . ": invalid type '$type'")
                unless defined $arg_size{$type};
        }
    }
    if (defined $gen_opnum{$name,$arity} and $obsolete[$gen_opnum{$name,$arity}]) {
	error("specific instructions may not be specified for obsolete instructions");
    }

    # Expand operands with multiple types to multiple instructions.
    # (For example, "get_list xy xy xy" will be expanded to six instructions.)
    my @res = ([]);
    foreach my $arg (@args) {
        my @old_res = @res;
        @res = ();
        my $marker = ($arg =~ s/[?]$//) ? '?' : '';
        foreach my $type (split(//, $arg)) {
            foreach my $args_ref (@old_res) {
                my @args = @$args_ref;
                push @args, "$type$marker";
                push @res, \@args;
            }
        }
    }

    # Store each specific instruction.
    my $key = "$name/$arity";
    foreach my $args_ref (@res) {
        @args = @$args_ref;
        my $arity = @args;
        my $loc = "$ARGV($.)";
        if (defined $specific_op_arity{$name}) {
            my($prev_arity,$loc) = @{$specific_op_arity{$name}};
            if ($arity != $prev_arity) {
                error("$name defined with arity $arity, " .
                      "but previously defined with arity $prev_arity at $loc");
            }
        }
        $specific_op_arity{$name} = [$arity,$loc];
        my $print_name = print_name($name, @args);
        if (defined $print_name{$print_name}) {
            error("$name @args: already defined at " .
                  $print_name{$print_name});
        }
        $print_name{$print_name} = $loc;
        push @{$specific_op{$key}}, [$name,$hotness,$varargs,@args];
    }

    # Done.
    ($name,$arity);
}

sub parse_c_args {
    local($_) = @_;
    my @res;

    while (s/^(\w[\w\d]*)\s*//) {
        push @res, $1;
        s/^,\s*// or last;
    }
    $_ eq '' or error("garbage in argument list: $_");
    @res;
}

sub pending_error {
    my(@message) = @_;
    my($where) = $. ? "$ARGV($.): " : "";
    $pending_errors++;
    warn $where, @message, "\n";
}

sub error {
    my(@message) = @_;
    my($where) = $. ? "$ARGV($.): " : "";
    die $where, @message, "\n";
}

sub sanity {
    die "internal error: ", @_, "\n";
}

sub comment {
    my($lang, @comments) = @_;
    my($prefix);

    if ($lang eq 'C') {
	print "/*\n";
	$prefix = " * ";
    } elsif ($lang eq 'erlang') {
	$prefix = '%% ';
    } else {
	$prefix = '# ';
    }
    my(@prog) = split('/', $0);
    my($prog) = $prog[$#prog];

    if (@comments) {
	my $line;
	foreach $line (@comments) {
	    print "$prefix$line\n";
	}
    } else {
	print "$prefix Warning: Do not edit this file.\n";
	print "$prefix Auto-generated by '$prog'.\n";
    }
    if ($lang eq 'C') {
	print " */\n";
    }
    print "\n";
}

#
# Combine micro instruction into instruction blocks.
#
sub combine_micro_instructions {
    my %groups;

    # Sanity check, normalize micro instructions.
    foreach my $instr (keys %combined_instrs) {
        my $ref = $combined_instrs{$instr};
        my($def_loc,$def) = @$ref;
        my($group,@subs) = split /[.]/, $def;
        my $arity = 0;
        @subs = map { "$group.$_" } @subs;
        foreach my $s (@subs) {
            my $code = $c_code{$s};
            defined $code or
                error("$def_loc: no definition of $s");
            $c_code_used{$s} = 1;
            my(undef,undef,@c_args) = @{$code};
            $arity += scalar(@c_args);
        }
        push @{$groups{$group}}, [$instr,$arity,@subs];
    }

    # Now generate code for each group.
    foreach my $group (sort keys %groups) {
        my($hotness,$code,@labels) =
            combine_instruction_group($group, @{$groups{$group}});
        push @generated_code, [$hotness,$code,@labels];
    }
}

sub combine_instruction_group {
    my($group,@in_instrs) = @_;
    my $gcode = '';             # Code for the entire group.
    my $group_hotness = COLD;

    # Get code for the head of the group (if any).
    my $head_name = "$group.head";
    $c_code_used{$head_name} = 1;
    my $head_code_ref = $c_code{$head_name};
    if (defined $head_code_ref) {
        my($head_code,$where,@c_args) = @{$head_code_ref};
        @c_args and error("$where: no arguments allowed for " .
                          "head function '$head_name()'");
        $gcode = $head_code . "\n";
    }

    # Variables.
    my %offsets;
    my @instrs;
    my %num_references;         # Number of references from other sub instructions.
    my $group_size = 999;

    #
    # Calculate the number of references from other sub instructions.
    # This number is useful in several ways:
    #
    # * If this number is 0, it is only used as the entry point for a
    #   function, implying that it does not need a label and that operands
    #   can be packed into the instruction word.
    #
    # * We'll use this number in the sort key, as a tie breaker for sub instructions
    #   at the same instruction offset.
    #
    foreach my $ref_instr (@in_instrs) {
        my(undef,undef,$first_sub,@other_subs) = @$ref_instr;
        $num_references{$first_sub} += 0; # Make sure it is defined.
        foreach my $sub (@other_subs) {
            $num_references{$sub}++;
        }
    }

    # Do basic error checking. Associate operands of instructions
    # with the correct micro instructions. Calculate offsets for micro
    # instructions.
    foreach my $ref_instr (@in_instrs) {
        my($specific,$arity,@subs) = @$ref_instr;
        my $specific_key = "$specific/$arity";
        my $specific_op_ref = $specific_op{$specific_key};
        error("no $specific_key instruction")
            unless defined $specific_op_ref;
        foreach my $specific_op (@$specific_op_ref) {
            my($name, $hotness, $varargs, @args) = @{$specific_op};
            $group_hotness = $hotness unless $group_hotness >= $hotness;
            my $offset = 0;
            my @rest = @args;
            my @new_subs;
            my $print_name = print_name($specific, @args);
            my $opcase = $print_name;
            my $last = $subs[$#subs];
            foreach my $s (@subs) {
                my $code = $c_code{$s};
                my(undef,undef,@c_args) = @{$code};
                my @first;
                foreach (0..$#c_args) {
                    push @first, shift @rest;
                }
                my $size = cg_combined_size(name => $s,
                                            first => $num_references{$s} == 0,
                                            args => \@first);
                $offsets{$s} = $offset
                    unless defined $offsets{$s} and $offsets{$s} < $offset;
                $offset += $size - 1;
                my $label = micro_label($s);
                push @new_subs, [$opcase,$label,$s,$size-1,@first];
                $opcase = '';
            }
            $spec_op_info{$print_name}->{'size'} = $offset + 1;
            $group_size = $offset if $group_size >= $offset;
            push @instrs, [$specific_key,@new_subs];
        }
    }

    # Link the sub instructions for each instructions to each
    # other.
    my @all_instrs;
    foreach my $instr (@instrs) {
        my($specific_key,@subs) = @{$instr};
        for (my $i = 0; $i < @subs; $i++) {
            my($opcase,$label,$s,$size,@args) = @{$subs[$i]};
            my $next = '';
            (undef,$next) = @{$subs[$i+1]} if $i < $#subs;
            my $instr_info = "$opcase:$label:$next:$s:$size:@args";
            push @all_instrs, [$label,$s,$offsets{$s},$instr_info];
        }
    }

    my %order_to_instrs;
    my %label_to_offset;
    my %order_to_offset;
    foreach my $instr (@all_instrs) {
        my($label,$s,$offset,$instr_info) = @$instr;
        my $sort_key = sprintf("%02d.%02d", $offset, $num_references{$s});
        push @{$order_to_instrs{$sort_key}}, $instr_info;
        $label_to_offset{$label} = $offset;
        $order_to_offset{$sort_key} = $offset;
    }

    my(@slots) = sort {$a <=> $b} keys %order_to_instrs;

    # Now generate the code for the entire group.
    my $offset = 0;
    my @opcase_labels;
    my %down;
    my %up;
    for(my $i = 0; $i < @slots; $i++) {
        my $key = $slots[$i];

        # Sort micro-instructions with OpCase before other micro-instructions.
        my(@instrs) = @{$order_to_instrs{$key}};
        my $order_func = sub {
            my $a_key = ($a =~ /^:/) ? "1$a" : "0$a";
            my $b_key = ($b =~ /^:/) ? "1$b" : "0$b";
            $a_key cmp $b_key;
        };
        @instrs = sort $order_func @instrs;

        my %seen;
        foreach my $instr (@instrs) {
            my($opcase,$label,$next,$s,$size,$args) = split ":", $instr;
            my(@first) = split " ", $args;

            my $seen_key = "$label:$next:" . scalar(@first);
            next if $opcase eq '' and $seen{$seen_key};
            $seen{$seen_key} = 1;
            $seen_key .= $opcase;

            if ($opcase ne '') {
                $gcode .= "OpCase($opcase):\n";
                push @opcase_labels, $opcase;
            }
            if ($num_references{$s}) {
                $gcode .= "$label:\n";
            }

            my $flags = '';
            my $transfer_to_next = '';
            my $inc = 0;

            unless ($i == $#slots) {
                $flags = "-micro_instruction";
                my $next_offset = $label_to_offset{$next};
                $inc = ($offset + $size) - $next_offset;
                $transfer_to_next = "I += $inc;\n" if $inc;
                $transfer_to_next .= "goto $next;\n\n";
            }

            my($gen_code,$down,$up) =
                cg_combined_code(name => $s,
                                 first => $num_references{$s} == 0,
                                 extra_comments => $flags,
                                 offset => $offset,
                                 comp_size => $group_size-$offset,
                                 inc => $inc,
                                 args =>\@first);
            my $spec_label = "$opcase$label";
            $down{$spec_label} = $down;
            $up{$spec_label} = $up;
            $gcode .= $gen_code . $transfer_to_next;
        }
        $offset = $order_to_offset{$slots[$i+1]} if $i < $#slots;
    }

    foreach my $print_name (@opcase_labels) {
        my $info = $spec_op_info{$print_name};
        $info->{'adj'} = $info->{'size'} - $group_size - 1;
    }

    #
    # Assemble pack specifications for all instructions in the group.
    #
    foreach my $instr (@instrs) {
        my(undef,@subs) = @{$instr};
        my $down = '';
        my $up = '';
        for (my $i = 0; $i < @subs; $i++) {
            my($opcase,$label) = @{$subs[$i]};
            my $spec_label = "$opcase$label";
            if (defined $down{$spec_label}) {
                $down = $down{$spec_label} . $down;
                $up = $up . $up{$spec_label};
            }
        }
        my $print_name = $subs[0]->[0];
        my $info = $spec_op_info{$print_name};
        $info->{'pack_spec'} = build_pack_spec("$down:$up");
    }

    ($group_hotness,"{\n$gcode\n}\n\n",@opcase_labels);
}

sub micro_label {
    my $label = shift;
    $label =~ s/[.]/__/g;
    $label;
}


#
# Basic code generation for one instruction.
#

sub cg_basic {
    my %params = (@_, pack_options => \@extended_pack_options);
    my($size,$code,$pack_spec) = code_gen(%params);
    $pack_spec = build_pack_spec($pack_spec);
    ($size,$code,$pack_spec);
}

#
# Calculate size for a micro instruction.
#

sub cg_combined_size {
    my %params = (@_,
                  pack_options => \@basic_pack_options,
                  size_only => 1);
    $params{pack_options} = \@extended_pack_options
        if $params{first};
    my($size) = code_gen(%params);
    $size;
}

#
# Generate code for a micro instruction.
#

sub cg_combined_code {
    my %params = (@_, pack_options => \@basic_pack_options);
    $params{pack_options} = \@extended_pack_options
        if $params{first};
    my($size,$code,$pack_spec) = code_gen(%params);
    if ($pack_spec eq '') {
        ($code,'','');
    } else {
        my($down,$up) = split /:/, $pack_spec;
        ($code,$down,$up);
    }
}

sub code_gen {
    my %params = (extra_comments => '',
                  offset => 0,
                  inc => 0,
                  size_only => 0,
                  @_);
    my $name = $params{name};
    my $extra_comments = $params{extra_comments};
    my $offset = $params{offset};
    my $inc = $params{inc};
    my @args = @{$params{args}};

    my $size = 0;
    my $flags = '';
    my @f;
    my $prefix = '';
    my $tmp_arg_num = 1;
    my $pack_spec = '';
    my $var_decls = '';

    #
    # Pack arguments for hot code with an implementation.
    #

    my $c_code_ref = $c_code{$name};
    if (defined $c_code_ref and $name ne 'catch') {
        my $pack_options = $params{pack_options};
        ($var_decls, $pack_spec, @args) = do_pack($name, $offset, $pack_options, @args);
    }

    #
    # Calculate the size of the instruction and generate each argument for
    # the macro.
    #

    my $need_block = 0;
    my $arg_offset = $offset;
    my $has_gen_dest = 0;
    @args = map { s/[?]$//g; $_ } @args;
    foreach (@args) {
	my($this_size) = $arg_size{$_};
      SWITCH:
	{
	    /^packed:d:(\d):(.*)/ and do {
                $var_decls .= "Eterm dst = $2;\n" .
                    "Eterm* dst_ptr = REG_TARGET_PTR(dst);\n";
                push(@f, "*dst_ptr");
                $this_size = $1;
                $has_gen_dest = 1;
                last SWITCH;
            };
	    /^packed:[a-zA-z]:(\d):(.*)/ and do {
                push(@f, $2);
                $this_size = $1;
                last SWITCH;
            };
	    /r/ and do {
                push(@f, "x(0)");
                last SWITCH;
            };
	    /[lxyS]/ and do {
                push(@f, $_ . "b(" . arg_offset($arg_offset) . ")");
                last SWITCH;
            };
	    /n/ and do {
                push(@f, "NIL");
                last SWITCH;
            };
	    /s/ and do {
                my($tmp) = "targ$tmp_arg_num";
                $var_decls .= "Eterm $tmp;\n";
                $tmp_arg_num++;
                push(@f, $tmp);
                $prefix .= "GetSource(" . arg_offset($arg_offset) . ", $tmp);\n";
                $need_block = 1;
                last SWITCH;
            };
	    /d/ and do {
                $var_decls .= "Eterm dst = " . arg_offset($arg_offset) . ";\n" .
                    "Eterm* dst_ptr = REG_TARGET_PTR(dst);\n";
                push(@f, "*dst_ptr");
                $has_gen_dest = 1;
                last SWITCH;
            };
            defined $arg_size{$_} and do {
                push @f, arg_offset($arg_offset);
                last SWITCH;
            };

	    die "$name: The generator can't handle $_, at";
	}
	$size += $this_size;
        $arg_offset += $this_size;
    }

    #
    # If the implementation is in beam_emu.c or if
    # the caller only wants the size, we are done.
    #
    if (not defined $c_code_ref or $params{size_only}) {
        return ($size+1, undef, '');
    }

    my $group_size = ($params{comp_size} || $size) + $inc;

    #
    # Generate main body of the implementation.
    #
    my($c_code,$where,@c_args) = @{$c_code_ref};
    my %bindings;
    $c_code_used{$name} = 1;

    if (@f != @c_args) {
        error("$where: defining '$name' with ", scalar(@c_args),
              " arguments instead of expected ", scalar(@f), " arguments");
    }

    for (my $i = 0; $i < @f; $i++) {
        my $var = $c_args[$i];
        $bindings{$var} = $f[$i];
    }
    $bindings{'NEXT_INSTRUCTION'} = "I+" . ($group_size+$offset+1);
    $bindings{'IP_ADJUSTMENT'} = $inc;
    $c_code = eval { expand_all($c_code, \%bindings) };
    unless (defined $c_code) {
        warn $@;
        error("... from the body of $name at $where");
    }
    my(@comments) = $c_code =~ m@//[|]\s*(.*)@g;
    $c_code =~ s@//[|]\s*(.*)\n?@@g;
    $flags = "@comments $extra_comments";

    #
    # Generate code for transferring to the next instruction.
    #
    my $dispatch_next;
    my $instr_offset = $group_size + $offset + 1;

    if ($flags =~ /-micro_instruction/) {
        $dispatch_next = "";
    } elsif ($flags =~ /-no_next/) {
        $dispatch_next = "ASSERT(!\"Fell through '$name' (-no_next)\");";
    } elsif ($flags =~ /-no_prefetch/) {
        $dispatch_next = "\nI += $instr_offset;\n" .
            "ASSERT(VALID_INSTR(*I));\n" .
            "Goto(*I);";
    } else {
        $var_decls .= "BeamInstr next_pf = BeamCodeAddr(I[$instr_offset]);\n";
        $dispatch_next = "\nI += $instr_offset;\n" .
            "ASSERT(VALID_INSTR(next_pf));\n" .
            "GotoPF(next_pf);";
    }

    #
    # Assemble the complete code for the instruction.
    #
    my $body = "$c_code$dispatch_next";
    if ($need_block) {
        $body = "$prefix\{\n$body\n}";
    } else {
        $body = "$prefix$body";
    }
    my $code = join("\n",
                    "{",
                    "$var_decls$body",
                    "}", "");

    # Make sure that $REFRESH_GEN_DEST() is used when a
    # general destination ('d') may have been clobbered by
    # a GC.
    my $gc_error = verify_gc_code($code, $has_gen_dest);
    if (defined $gc_error) {
        warn $gc_error;
        error("... from the body of $name at $where");
    }

    # Done.
    ($size+1, $code, $pack_spec);
}

sub verify_gc_code {
    my $code = shift;
    my $has_gen_dest = shift;

    return unless $has_gen_dest;

    if ($code =~ /$GC_REGEXP/o) {
        my $code_after_gc = substr($code, $+[0]);
        unless ($code_after_gc =~ /dst_ptr = REG_TARGET_PTR/) {
            return "pointer to destination register is invalid after GC -- " .
                "use \$REFRESH_GEN_DEST()\n";
        }
    }
    return undef;
}

sub arg_offset {
    my $offset = shift;
    "I[" . ($offset+1) . "]";
}

sub expand_all {
    my($code,$bindings_ref) = @_;
    my %bindings = %{$bindings_ref};

    # Expand all $Var occurrences.
    $code =~ s/[\$](\w[\w\d]*)(?!\()/defined $bindings{$1} ? $bindings{$1} : "\$$1"/ge;

    # Find calls to macros, $name(...), and expand them.
    my $res = "";
    while ($code =~ /[\$](\w[\w\d]*)\(/) {
        my $macro_name = $1;
        my $keep = substr($code, 0, $-[0]);
        my $after = substr($code, $+[0]);

        my $body;
        ($body,$code) = expand_macro($macro_name, $after, \%bindings);
        $res .= "$keep$body";
    }

    $res . $code;
}

sub expand_macro {
    my($name,$rest,$bindings_ref) = @_;

    my $c_code = $c_code{$name};
    defined $c_code or
        error("calling undefined macro '$name'...");
    $c_code_used{$name} = 1;
    my ($body,$where,@vars) = @{$c_code};

    # Separate the arguments into @args;
    my @args;
    my $level = 1;
    my %inc = ('(' => 1, ')' => -1,
               '[' => 1, ']' => -1,
               '{' => 1, '}' => -1);
    my $arg = undef;
    while ($rest =~ /([,\(\[\{\}\]\)]|([^,\(\[\{\}\]\)]*))/g) {
        my $token = $1;
        my $inc = $inc{$token} || 0;
        $level += $inc;
        if ($level == 0) {
            $rest = substr($rest, pos($rest));
            push @args, $arg if defined $arg;
            last;
        }
        if ($token eq ',') {
            if ($level == 1) {
                push @args, $arg;
                $arg = "";
            }
            next;
        }
        $arg .= $token;
    }

    # Trim leading whitespace from each argument.
    foreach my $arg (@args) {
        $arg =~ s/^\s*//;
    }

    # Make sure that the number of arguments are correct.
    if (@vars != @args) {
        error("calling $name with ", scalar(@args),
              " arguments instead of expected ", scalar(@vars), " arguments...");
    }

    # Now combine bindings from the parameter names and arguments.
    my %bindings = %{$bindings_ref};
    my %new_bindings;

    # Keep the special, pre-defined bindings.
    foreach my $key (qw(NEXT_INSTRUCTION IP_ADJUSTMENT)) {
        $new_bindings{$key} = $bindings{$key};
    }

    for (my $i = 0; $i < @vars; $i++) {
        my $arg = $args[$i];
        $arg = eval { expand_all($arg, \%bindings) };
        unless (defined $arg) {
            warn $@;
            die "... from the body of $name at $where\n";
        }
        $new_bindings{$vars[$i]} = $arg;
    }

    $body = eval { expand_all($body, \%new_bindings) };
    unless (defined $body) {
        warn $@;
        die "... from the body of $name at $where\n";
    }

    # Handle built-in macros.
    if ($name eq 'OPERAND_POSITION') {
        if ($body =~ /^I\[(\d+)\]$/) {
            $body = $1;
        } else {
            $body = 0;
        }
    } elsif ($name eq 'IF') {
        my $expr = $new_bindings{Expr};
        my $bool = eval $expr;
        if ($@ ne '') {
            &error("bad expression '$expr' in \$IF()");
        }
        my $part = $bool ? 'IfTrue' : 'IfFalse';
        $body = $new_bindings{$part};
    } elsif ($name eq 'REFRESH_GEN_DEST') {
        $body = "dst_ptr = REG_TARGET_PTR(dst)";
    }


    # Wrap body if needed and return result.
    $body = "do {\n$body\n} while (0)"
        if needs_do_wrapper($body);
    ($body,$rest);
}

# Conservative heuristic to determine whether a do { ... } while(0)
# wrapper is needed.
sub needs_do_wrapper {
    local $_ = shift;

    s@^//[|][^\n]*\n@@;
    s@^\s*@@s;
    s@^/[*].*[*]/\s*@@s;
    return 1 if /^(Eterm|Uint|Sint|int|unsigned)/; # Definitely needed.
    return 0 if /^do/;
    return 0 if /^SET_I/;
    return 0 if /^SET_CP/;
    return 0 if /^ASSERT/;
    return 0 if /^DTRACE/;
    return 0 if /^[A-Za-z_]*\s*=/;
    return 0 if /^c_p->/;
    return 0 if /^[A-Z_]*SWAPOUT/;
    return 0 if /^if\s*[(]/;
    return 0 if /^goto\b/;
    return 0 if /^\d+/;
    return 1;                   # Not sure, say that it is needed.
}

sub do_pack {
    my($name,$offset,$pack_opts_ref,@args) = @_;
    my @pack_opts = @$pack_opts_ref;
    my $opt_arg_pos = -1;

    # Look for an optional use operand not as the first argument.
    if (@args and $args[0] !~ /[?]$/) {
        for (my $pos = 0; $pos < @args; $pos++) {
            if ($args[$pos] =~ /[?]$/) {
                $opt_arg_pos = $pos;
                last;
            }
        }
    }

    @args = map { s/[?]$//; $_ } @args; # Remove any optional use marker.

    # If there is an optional operand, extend the array of pack options.
    if ($opt_arg_pos >= 0) {
        my @new_pack_opts = grep { $_ & PACK_IN_INSTR_WORD } @pack_opts;
        @new_pack_opts = map {
            ($_ & ~ PACK_IN_INSTR_WORD) | PACK_OPT_IN_INSTR_WORD;
        } @new_pack_opts;
        push @pack_opts, @new_pack_opts;
    }

    my $ret = ['', ':', @args];
    my $score = 0;

    foreach my $options (@pack_opts) {
        my $this_opt_arg_pos = ($options & PACK_OPT_IN_INSTR_WORD) ? $opt_arg_pos : -1;
        my($this_score,$this_result) =
            do_pack_one($name, $options, $this_opt_arg_pos, $offset, @args);
        if ($this_score > $score) {
            $ret = $this_result;
            $score = $this_score;
        }
    }
    return @$ret;
}

sub do_pack_one {
    my($name,$options,$opt_arg_pos,$offset,@args) = @_;
    my($packable_args) = 0;
    my @bits_needed;            # Bits needed for each argument.
    my $pack_in_iw = $options & PACK_IN_INSTR_WORD;

    #
    # Define the minimum number of bits needed for the packable argument types.
    #
    my %bits_needed = ('x' => 10,
                       'y' => 10,
                       'Q' => 10,
                       'l' => 10,
                       'S' => 16,
                       'd' => 16,
                       't' => 16);
    if ($wordsize == 64) {
        $bits_needed{'I'} = 32;
        if ($options & PACK_JUMP) {
            $bits_needed{'f'} = 32;
            $bits_needed{'j'} = 32;
        }
    }

    #
    # Count the number of packable arguments.
    #
    foreach my $arg (@args) {
        if (defined $bits_needed{$arg}) {
	    $packable_args++;
            push @bits_needed, $bits_needed{$arg};
	} else {
	    push @bits_needed, 0;
	}
        if ($arg =~ /^[fj]$/) {
            # Only pack the first occurrence of 'f' or 'j'.
            delete $bits_needed{'f'};
            delete $bits_needed{'j'};
        }
    }

    #
    # Check whether any packing can be done.
    #
    my $nothing_to_pack = $packable_args == 0 ||
        $packable_args == 1 && $options == 0;
    if ($nothing_to_pack) {
        # The packing engine in the loader processes the operands from
        # right to left. Rightmost operands that are not packed must
        # be stacked and then unstacked.
        #
        # Because instructions may be broken up into micro
        # instructions, we might not see all operands at once. So
        # there could be a micro instructions that packs the operands
        # to the left of the current micro instruction. If that is the
        # case, it is essential that we generate stacking and
        # unstacking instructions even when no packing is
        # possible. (build_pack_spec() will remove any unnecessary
        # stacking and unstacking operations.)
        #
        # Here is an example. Say that we have this instruction:
        #
        #     i_plus x x j d
        #
        # that comprises two micro instructions:
        #
        #     i_plus.fetch x x
        #     i_plus.execute j d
        #
        # This function (do_pack_one()) will be called twice, once to pack
        # 'x' and 'x', and once to pack 'j' and 'd'.
        #
        # On a 32-bit machine, the 'j' and 'd' operands can't be
        # packed because 'j' requires a full word. The two 'x'
        # operands in the i_plus.fetch micro instruction will be
        # packed, though, so we must generate instructions for packing
        # and unpacking the 'j' and 'd' operands.
        my $down = '';
        my $up = '';
        foreach my $arg (@args) {
            my $push = 'g';
            if ($type_bit{$arg} & $type_bit{'q'}) {
                # The operand may be a literal.
                $push = 'q';
            } elsif ($type_bit{$arg} & $type_bit{'f'}) {
                # The operand may be a failure label.
                $push = 'f';
            }
            $down = "$push${down}";
            $up = "${up}p";
        }
        my $pack_spec = "$down:$up";
        return (1, ['',$pack_spec,@args]);
    }

    #
    # Determine how many arguments we should pack into each word.
    #
    my @args_per_word;
    my @need_wide_mask;
    my $bits;
    my $this_wordsize;
    my $word = -1;

    my $next_word = sub {
        $word++;
        $args_per_word[$word] = 0;
        $need_wide_mask[$word] = 0;
        $bits = 0;
        $this_wordsize = $wordsize;
    };

    $next_word->();
    $this_wordsize = 32 if $pack_in_iw;
    for (my $arg_num = 0; $arg_num < @args; $arg_num++) {
            my $needed = $bits_needed[$arg_num];

            next unless $needed;
            next if $arg_num == $opt_arg_pos;

            if ($bits+$needed > $this_wordsize) { # Does not fit.
                $next_word->();
            }
            if ($args_per_word[$word] == 4) { # Can't handle more than 4 args.
                $next_word->();
            }
            if ($needed == 32 and $args_per_word[$word] > 1) {
                # Must only pack two arguments in this word, and there
                # are already at least two arguments here.
                $next_word->();
            }
            $args_per_word[$word]++;
            $bits += $needed;
            if ($needed == 32) {
                $need_wide_mask[$word]++;
            }
            if ($need_wide_mask[$word] and $bits > 32) {
                # Can only pack two things in a word where one
                # item is 32 bits. Force the next item into
                # the next word.
                $bits = $this_wordsize;
            }
    }

    #
    # Try to balance packing between words.
    #
    if (@args_per_word == 1 and $args_per_word[0] == 1 and $pack_in_iw) {
        # Don't rebalance.
    } elsif ($args_per_word[$#args_per_word] == 1) {
        if ($args_per_word[$#args_per_word-1] < 3) {
            pop @args_per_word;
        } else {
            $args_per_word[$#args_per_word-1]--;
            $args_per_word[$#args_per_word]++;
        }
    } elsif (@args_per_word == 2 and
             $args_per_word[0] == 4 and
             $args_per_word[1] == 2) {
        $args_per_word[0] = 3;
        $args_per_word[1] = 3;
    } elsif (@args_per_word == 2 and
             $args_per_word[0] == 3 and
             $args_per_word[1] == 1) {
        $args_per_word[0] = 2;
        $args_per_word[1] = 2;
    }

    my $size = 0;
    my $pack_prefix = '';
    my $down = '';		# Pack commands (towards instruction
				# beginning).
    my $up = '';		# Pack commands (storing back while
				# moving forward).
    my $arg_num = 0;            # Number of argument.

    # Skip an unpackable argument. Also handle packing of
    # an single operand into the instruction word.
    my $skip_unpackable = sub {
        my($arg) = @_;

        if ($arg_num == $opt_arg_pos) {
            my $pack = chr(ord('#') + $arg_num);
            $down = PACK_CMD_WIDE . "$pack$down";
            my $unpack = "BeamExtraData(I[0])";
            $args[$arg_num] = "packed:$arg:0:${arg}b($unpack)";
        } elsif ($arg_size{$arg}) {
            # Save the argument on the pack engine's stack.
            my $push = 'g';
            if ($type_bit{$arg} & $type_bit{'q'}) {
                # The operand may be a literal.
                $push = 'q';
            } elsif ($type_bit{$arg} & $type_bit{'f'}) {
                # The operand may be a failure label.
                $push = 'f';
            }
            $down = "$push${down}";
            $up = "${up}p";
        }
    };

    #
    # Now generate the packing instructions.  One complication is that
    # the packing engine works from right-to-left, but we must generate
    # the instructions from left-to-right because we must calculate
    # instruction sizes from left-to-right.
    for (my $word = 0; $word < @args_per_word; $word++) {
        my $ap = 0;              # Argument number within word.
        my $packed_var = "tmp_packed" . ($word+1);
        my $args_per_word = $args_per_word[$word];
        my $pack_word_size = ($pack_in_iw && $word == 0) ? 32 : $wordsize;

        my($shref,$mref,$iref,$unpack_suffix)  =
            get_pack_parameters($name, $args_per_word, $pack_word_size,
                                $need_wide_mask[$word]);
        my @shift = @$shref;
        my @mask = @$mref;
        my @instr = @$iref;

        while ($ap < $args_per_word) {
            my $reg = $args[$arg_num];
            my $this_size = $arg_size{$reg};

            if ($bits_needed[$arg_num]) {
                $this_size = 0;

                if ($ap == 0) {
                    my $packed_data;
                    if ($pack_in_iw and $word == 0) {
                        $packed_data = "BeamExtraData(I[0])";
                        if ($args_per_word == 1) {
                            $packed_var = $packed_data;
                        } else {
                            $pack_prefix .= "Eterm $packed_var = $packed_data;\n";
                        }
                        my $pack = chr(ord('#') + $size);
                        $down = "$pack$down";
                    } else {
                        $packed_data = arg_offset($size + $offset);
                        $pack_prefix .= "Eterm $packed_var = $packed_data;\n";
                        $down = "P$down";
                        $up .= "p";
                        $this_size = 1;
                    }
                }

                $down = "$instr[$ap]$down";
                my $unpack = make_unpack($packed_var, $shift[$ap], $mask[$ap]);
                my $macro = "$reg$unpack_suffix";
                $args[$arg_num] = "packed:$reg:$this_size:$macro($unpack)";

                $ap++;
            } else {
                $skip_unpackable->($reg);
            }
            $size += $this_size;
            $arg_num++;
        }
    }

    #
    # Skip any unpackable arguments at the end.
    #
    while ($arg_num < @args) {
        my $arg = $args[$arg_num];
        $skip_unpackable->($arg);
        $size += $arg_size{$arg};
        $arg_num++;
    }

    my $pack_spec = "$down:$up";
    my $score = pack_score($options, @args);

    return ($score, [$pack_prefix,$pack_spec,@args]);
}

sub get_pack_parameters {
    my($name,$args_per_word,$pack_word_size,$wide_mask) = @_;
    my(@shift,@mask,@instr);
    my $unpack_suffix = 'b';

    if ($wide_mask and $args_per_word > 1) {
        @shift = ('0', 'BEAM_WIDE_SHIFT');
        @mask = ('BEAM_WIDE_MASK', $WHOLE_WORD);
        @instr = (PACK_CMD_WIDE) x 2;
    } elsif ($args_per_word == 1) {
        @shift = ('0');
        @mask = ($WHOLE_WORD);
        @instr = (PACK_CMD_WIDE);
    } elsif ($args_per_word == 2) {
        if ($pack_word_size != $wordsize) {
            # 64-bit word size, pack 32 bits into instruction word.
            @shift = ('0', 'BEAM_TIGHT_SHIFT');
            @mask  = ('BEAM_TIGHT_MASK', $WHOLE_WORD);
            @instr = (PACK_CMD_TIGHT) x 2;
        } else {
            # 32/64 bit word size
            @shift = ('0', 'BEAM_LOOSE_SHIFT');
            @mask  = ('BEAM_LOOSE_MASK', $WHOLE_WORD);
            @instr = (PACK_CMD_LOOSE) x 2;
        }
    } elsif ($args_per_word == 3) {
        if ($pack_word_size != $wordsize) {
            # 64-bit word size, pack 3 register numbers into instruction word.
            @shift = ('0', 'BEAM_TIGHTEST_SHIFT', '(2*BEAM_TIGHTEST_SHIFT)');
            @mask = ('BEAM_TIGHTEST_MASK', 'BEAM_TIGHTEST_MASK', $WHOLE_WORD);
            @instr = (PACK_CMD_TIGHTEST) x 3;
            $unpack_suffix = '';
        } else {
            # 32/64 bit word size.
            @shift = ('0', 'BEAM_TIGHT_SHIFT', '(2*BEAM_TIGHT_SHIFT)');
            if ($wordsize == 32) {
                @mask = ('BEAM_TIGHT_MASK') x 3;
            } elsif ($wordsize == 64) {
                @mask = ('BEAM_TIGHT_MASK', 'BEAM_TIGHT_MASK', $WHOLE_WORD);
            }
            @instr = (PACK_CMD_TIGHT) x 3;
        }
    } elsif ($args_per_word == 4) {
        # 64 bit word size only.
        @shift = ('0',
                  'BEAM_LOOSE_SHIFT',
                  '(2*BEAM_LOOSE_SHIFT)',
		  '(3*BEAM_LOOSE_SHIFT)');
        @mask = ('BEAM_LOOSE_MASK', 'BEAM_LOOSE_MASK',
                 'BEAM_LOOSE_MASK', $WHOLE_WORD);
        @instr = (PACK_CMD_LOOSE) x 4;
    }

    unless (@shift) {
        error("$name: internal packing error: args_per_word=$args_per_word, " .
              "pack_word_size=$pack_word_size");
    }

    (\@shift,\@mask,\@instr,$unpack_suffix);
}

sub pack_score {
    my($options,@args) = @_;
    my $size = 0;

    # Calculate the number of words.
    foreach (@args) {
        if (/^packed:[^:]*:(\d+)/) {
            $size += $1;
        } else {
            $size += $arg_size{$_}
        }
    }

    # Less numbers of words give a higher score; for the same number of
    # words, using PACK_JUMP or PACK_IN_INSTR_WORD gives a lower score.
    my $score = 1 + 10*($max_spec_operands - $size);
    if (($options & PACK_OPT_IN_INSTR_WORD) != 0) {
        $score += 4;
    } elsif ($options == PACK_IN_INSTR_WORD) {
        $score += 0;
    } elsif ($options == PACK_JUMP) {
        $score += 1;
    } elsif ($options == (PACK_JUMP|PACK_IN_INSTR_WORD)) {
        $score += 2;
    } elsif ($options == 0) {
        $score += 3;
    }
    $score;
}

sub make_unpack {
    my($packed_var, $shift, $mask) = @_;

    my $e = $packed_var;
    $e = "($e>>$shift)" if $shift;
    $e .= "&$mask" unless $mask eq $WHOLE_WORD;
    $e;
}

sub build_pack_spec {
    my $pack_spec = shift;
    return '' if $pack_spec eq '';
    my($down,$up) = split /:/, $pack_spec;
    while ($down =~ /[gfq]$/ and $up =~ /^p/) {
        $down = substr($down, 0, -1);
        $up = substr($up, 1);
    }
    "$down$up";
}

sub quote {
    local($_) = @_;
    return "'$_'" if $_ eq 'try';
    return "'$_'" if $_ eq 'catch';
    return "'$_'" if $_ eq 'receive';
    return "'$_'" if $_ =~ /^[A-Z]/;
    $_;
}

#
# Parse instruction transformations when they first appear.
#
sub parse_transformation {
    local($_) = @_;
    my($orig) = $_;

    my($from, $to, @rest) = split(/\s*=>\s*/);
    my(@op);
    my $rest_var;

    if (@rest) {
        error("only one '=>' operator is allowed");
    }

    # The source instructions.

    my(@from) = split(/\s*\|\s*/, $from);
    foreach (@from) {
	if (/^(\w+)\((.*?)\)/) {
	    my($name, $arglist) = ($1, $2);
	    $_ = (compile_transform_function($name, split(/\s*,\s*/, $arglist)));
	} else {
	    (@op) = split;
	    ($rest_var,$_) = compile_transform(1, $rest_var, @op);
	}
    }

    #
    # Check for a function which should be called to provide the new
    # instructions if the left-hand side matched.  Otherwise there is
    # an explicit list of instructions.
    #

    my @to;
    if ($to =~ /^(\w+)\((.*?)\)(.*)/) {
	my($name, $arglist, $garbage) = ($1, $2, $3);
        if ($garbage =~ /\S/) {
            error("garbage after call to '$name()'");
        }
	@to = (compile_transform_function($name, split(/\s*,\s*/, $arglist)));
    } elsif ($to =~ /^\s*_\s*$/) {
        # _ means that instructions on the left side should be removed.
        @to = ();
    } else {
	@to = split(/\s*\|\s*/, $to);
        if (@to == 0) {
            error("the right-hand side of a transformation must not be empty;\n" .
                  "  use _ to indicate that no instructions should be produced");
        }
	foreach (@to) {
	    (@op) = split;
	    (undef,$_) = compile_transform(0, $rest_var, @op);
	}
    }
    $orig =~ tr/ \t/ /s;
    push(@transformations, ["$ARGV($.)", $orig, [@from], [reverse @to]]);
}

sub compile_transform_function {
    my($name, @args) = @_;

    [".$name", 0, @args];
}

sub compile_transform {
    my($src, $rest_var, $name, @ops) = @_;
    my $arity = 0;

    foreach (@ops) {
	my(@list) = tr_parse_op($src, $_);
	if ($list[1] eq '*') {
	    $rest_var = $list[0];
	} elsif (defined $rest_var and $list[0] eq $rest_var) {
	    $list[1] = '*';
	} else {
	    $arity++;
	}
	$_ = [ @list ];
    }
    
    if (defined $gen_opnum{$name,$arity} && $obsolete[$gen_opnum{$name,$arity}]) {
	error("obsolete function must not be used in transformations");
    }

    if ($src) {
	$is_transformed{$name,$arity} = 1;
    }
    
    ($rest_var,[$name,$arity,@ops]);
}

sub tr_parse_op {
    my($src, $op) = @_;
    my($var) = '';
    my($type) = '';
    my($type_val) = 0;
    my($cond) = '';
    my($cond_val) = '';

    local($_) = $op;

    # Get the variable name if any.

    if (/^(_?[A-Z]\w*)(.*)/) {
	$var = $1;
	$_ = $2;
	error("garbage after variable")
	    unless /^=(.*)/ or /^(\s*)$/;
	$_ = $1;
    }

    # Get the type if any.

    if (/^([a-z*]+)(.*)/) {
	$type = $1;
	$_ = $2;
        error("$type: only a single type is allowed on right side of transformations")
            if not $src and length($type) > 1;
	foreach (split('', $type)) {
            next if $src and $type eq '*';
            error("$op: not a type")
                unless defined $type_bit{$_};
            error("$op: the type '$_' is not allowed in transformations")
                unless defined $pattern_type{$_};
            if (not $src) {
                error("$op: type '$_' is not allowed on the right side of transformations")
                    unless defined $construction_type{$_};
            }
        }
    }

    # Get an optional condition. (In source.)

    if (/^==(.*)/) {
	$cond = 'is_eq';
	$cond_val = $1;
	$_ = '';
    } elsif (/^\$is_bif(.*)/) {
	$cond = 'is_bif';
	$cond_val = -1;
	$_ = $1;
    } elsif (/^\$is_not_bif(.*)/) {
	$cond = 'is_not_bif';
	$cond_val = -1;
	$_ = $1;
    } elsif (m@^\$bif:(\w+):(\w+)/(\d)(.*)@) {
	$cond = 'is_bif';
	if ($1 eq 'erlang') {
	    $cond_val = "BIF_$2_$3";
	} else {
	    $cond_val = "BIF_$1_$2_$3";
	}
	$_ = $4;
    } elsif (m@^\$func:(\w+):(\w+)/([_\d])(.*)@) {
	my $arity = $3 eq '_' ? 1024 : $3;
	$cond = 'is_func';
	$cond_val = "$1:$2:$arity";
	$_ = $4;
    }

    # Get an optional value. (In destination.)
    if ($type eq 'x') {
        $type_val = 1023;
    } elsif ($type eq 'a') {
        $type_val = 'am_Empty';
    } else {
        $type_val = 0;
    }
    if (/^=(.*)/) {
	error("$op: value not allowed in source")
	    if $src;
        error("$op: the type 'n' must not be given a value")
            if $type eq 'n';
	$type_val = $1;
	$_ = '';
    }

    # Nothing more is allowed after the command.

    error("garbage '$_' after operand: $op")
	unless /^\s*$/;

    # Check the conditions.

    if ($src) {
        error("$op: the type '$type' is not allowed to be compared with a literal value")
            if $cond and not $construction_type{$type};
    } else {
	error("$op: condition not allowed in destination")
	    if $cond;
	error("$op: variable name and type cannot be combined in destination")
	    if $var and $type;
    }

    ($var,$type,$type_val,$cond,$cond_val);
}

#
# Generate code for all transformations.
#

sub tr_gen {
    my(@g) = @_;

    my($ref, $key, $instr);	# Loop variables.

    foreach $ref (@g) {
	my($line, $orig_transform, $from_ref, $to_ref) = @$ref;
	my $so_far = tr_gen_from($line, @$from_ref);
	tr_gen_to($line, $orig_transform, $so_far, @$to_ref);
    }

    #
    # Print predicate and generation functions.
    #
    gen_tr_code('pred.');
    gen_tr_code('gen.');

    #
    # Group instructions.
    #
    foreach $key (sort keys %gen_transform) {
        $gen_transform{$key} = group_tr($gen_transform{$key});
    }

    #
    # Print the generated transformation engine.
    #

    my $vars = join(", ", map { "v$_" } 0..$te_max_vars-1);
    print <<"END";
int erts_transform_engine(LoaderState* st) {
  BeamOpArg $vars;
  BeamOp* first = st->genop;
  BeamOp* instr = first;
  BeamOp* keep;
  BeamOpArg* rest_args;
  int num_rest_args;
END

    my $label = 0;
    my $ap = 0;
    my $ip = 1;
    my $need_label = 0;

    print "  switch (first->op) {\n";
    foreach $key (sort keys %gen_transform) {
        my $lref = $gen_transform{$key};

        my($name,$arity) = $key =~ m@^([^/]+)/(\d+)$@;
        print "    case $gen_opnum{$name,$arity}: /* $key */\n";
        $need_label = 0;

        for (my $i = 0; $i < @$lref; $i++) {
            my(undef,undef,undef,$comment,@instr) = @{${$lref}[$i]};
            $comment =~ s/\n(.)/\n    $1/g;
            print $comment;

            if ($need_label) {
                print <<"END";
  fail$label:
    instr = first;
END
            }
            $label++;
            $need_label = 1;
            $ap = 0;
            $ip = 0;
            my $fail_action = "return TE_FAIL";

            foreach $instr (@instr) {
                my($size, $instr_ref, $comment) = @$instr;
                my($op, @args) = @$instr_ref;
                if ($op eq 'next_arg') {
                    $ap++;
                } elsif ($op eq 'next_instr') {
                    $ap = 0;
                    $ip++;
                } elsif ($op eq 'new_instr') {
                    $ap = 0;
                } elsif ($op eq 'commit') {
                    $ap = 0;
                } elsif ($op eq 'commit_new_instr') {
                    $ap = 0;
                    $ip--;
                } elsif ($op eq 'keep') {
                    $ip--;
                } elsif ($op eq 'try_me_else') {
                    $fail_action = "goto fail$label";
                } elsif ($op eq 'skip_unless') {
                    $fail_action = "goto fail$label";
                    $need_label = 0;
                }
                gen_te_instr($ap, $ip, $fail_action, $comment, $op, @args);
            }
        }
        print "\n";
    }
    print "    default: ASSERT(0); return TE_FAIL;\n";
    print "  }\n";
    print "}\n\n";
}

sub gen_te_instr {
    my($ap,$ip,$fail_action,$comment,$op,@args) = @_;

    if ($op eq 'next_arg') {
        ;
    } elsif ($op eq 'nop') {
        ;
    } elsif ($op eq 'try_me_else') {
        ;
    } elsif ($op eq 'try_me_else_fail') {
        ;
    } elsif ($op eq 'skip_unless') {
        my($instr,$count) = @args;
        my($fail_label) = $fail_action =~ /^goto fail(\d+)/;
        if (defined $fail_label) {
            $fail_action = "goto fail" . ($fail_label+$count);
        }
        print <<"END";
    /*
     * Note that the caller of transform_engine() guarantees that
     * there is always a second instruction available.
     */
    ASSERT(instr);
    if (instr->next->op != $instr) {
        /* The second instruction is wrong. Skip ahead. */
        $fail_action;
    }
END
    } elsif ($op eq 'set_var') {
        my $var = "v$args[0]";
        print <<"END";
    $var = instr->a[$ap]; /* $comment */
END
    } elsif ($op eq 'is_bif') {
        my $bif_number = $args[0];
        my $specific_bif_action = "";
        my $bif_comment;
        if ($bif_number eq '-1') {
            $bif_comment = "Is $comment a BIF?";
        } else {
            $bif_comment = "Is $comment $bif_number?";
            $specific_bif_action = <<"END";
        if (entry != &bif_table[$bif_number]) {
          $fail_action; /* Not $bif_number */
        }
END
        }
        print <<"END";
    /* $bif_comment */
    ASSERT(instr->a[$ap].type == TAG_u);
    if (instr->a[$ap].type != TAG_u) {
      $fail_action;
    } else {
      int i = instr->a[$ap].val;
      ASSERT(i < st->beam.imports.count);
      if (i >= st->beam.imports.count) {
        $fail_action;
      } else {
        BifEntry *entry = st->bif_imports[i];

        if (!entry) {
          $fail_action; /* Not a BIF */
        }
$specific_bif_action
      }
    }
END
    } elsif ($op eq 'is_not_bif') {
        my $bif_number = $args[0];
        print <<"END";
    /* Is $comment not a BIF? */
    {
      int i = instr->a[$ap].val;

      /*
       * In debug build, the type must be 'u'.
       */
      ASSERT(instr->a[$ap].type == TAG_u);
      if (instr->a[$ap].type != TAG_u) {
        $fail_action;
      } else if (i < st->beam.imports.count) {
        BeamFile_ImportEntry *import;

        if (st->bif_imports[i]) {
          $fail_action;
        }

        /* erlang:apply/2,3 are strange. They exist as (dummy) BIFs
         * so that they are included in the export table before
         * the erlang module is loaded. They also exist in the
         * erlang module as functions. When used in code, a special
         * Beam instruction is used.
         *
         * Below we recognize erlang:apply/2,3 as special. This is
         * necessary because after setting a trace pattern on
         * them, you can no longer see from the export entry that
         * they are special. */
        import = &st->beam.imports.entries[i];

        if (import->module == am_erlang) {
          if (import->function == am_apply) {
            if (import->arity == 2 || import->arity == 3) {
              $fail_action;
            }
          }
        }
      }
    }
END
    } elsif ($op eq 'is_eq') {
        my $val = $args[0];
        print <<"END";
    /* Test value */
    if (instr->a[$ap].val != $val) {
      $fail_action;
    }
END
    } elsif ($op eq 'is_func') {
        my($mod,$name,$arity) = @args;
        print <<"END";
    /* Is $comment the function $mod:$name/$arity? */
    ASSERT(instr->a[$ap].type == TAG_u);
    if (instr->a[$ap].type != TAG_u) {
      $fail_action;
    } else {
      int i = instr->a[$ap].val;
      BeamFile_ImportEntry* import;
      ASSERT(i < st->beam.imports.count);
      if (i >= st->beam.imports.count) {
        $fail_action;
      }
      import = &st->beam.imports.entries[i];
      if (import->module != $mod || import->function != $name || import->arity != $arity) {
        $fail_action;
      }
    }
END
    } elsif ($op eq 'is_type') {
        my $mask = $args[0];
        print <<"END";
    /* Test type */
    if (((1 << instr->a[$ap].type) & $mask) == 0) { /* $comment */
      $fail_action;
    }
END
    } elsif ($op eq 'next_instr') {
        my $expected = $args[0];
        my $window_check = "ASSERT(instr)";
        if ($ip > 1) {
            $window_check = "if (instr == NULL) return TE_SHORT_WINDOW";
        }
        print <<"END";
    /* Advance to next instruction */
    instr = instr->next;
    $window_check;
    if (instr->op != $expected) { /* $comment */
      $fail_action;
    }
END
    } elsif ($op eq 'call') {
        my($name,@vars) = @args;
        my $call = $name . "(" . join(", ", ("st", @vars)) . ")";
        print <<"END";
    /* Call generator $name() */
    {
      BeamOp** lastp;
      BeamOp* new_instr = $call;

      if (new_instr == NULL) {
        $fail_action;
      }

      keep = instr->next; /* The next_instr was optimized away. */

      lastp = &new_instr;
      while (*lastp != NULL) {
          lastp = &((*lastp)->next);
      }

      *lastp = keep;
      instr = new_instr;
    }
END
    } elsif ($op eq 'pred') {
        my($name,@vars) = @args;
        my $pred = "$name(" . join(", ", ("st", @vars)) . ")";
        print <<"END";
    /* Call predicate $name() */
    if (!$pred) {
      $fail_action;
    }
END
    } elsif ($op eq 'rest_args') {
        my($formal_arity) = @args;
        print <<"END";
    /* Store dynamic arguments ($comment) */
    num_rest_args = instr->arity - $formal_arity;
    rest_args = &instr->a[$formal_arity];
END
    } elsif ($op eq 'commit') {
        print <<"END";
    /* $comment */
    keep = instr = instr->next;
END
    } elsif ($op eq 'commit_new_instr') {
        my($instr_op) = @args;
        my $arity = $gen_arity{$gen_opname[$instr_op]};
        print <<"END";
    /* $comment; reusing last instruction on the left-hand side */
    ASSERT(instr->a == instr->def_args);
    keep = instr;
    instr->op = $instr_op;
    instr->arity = $arity;
END
    } elsif ($op eq 'keep') {
        print <<"END";
    /* Keep the current instruction unchanged */
    keep = instr;
END
    } elsif ($op eq 'new_instr') {
        my($instr_op) = @args;
        my $arity = $gen_arity{$gen_opname[$instr_op]};
        print <<"END";
    /* Create instruction: $comment */
    {
      BeamOp* new_instr = beamopallocator_new_op(&st->op_allocator);
      new_instr->next = instr;
      instr = new_instr;
      instr->op = $instr_op;
      instr->arity = $arity;
    }
END
    } elsif ($op eq 'rename') {
        my($instr_op) = @args;
        my $arity = $gen_arity{$gen_opname[$instr_op]};
        print <<"END";
    /* Rename instruction keeping the arguments */
    instr->op = $instr_op;
    instr->arity = $arity;
    return TE_OK;
END
    } elsif ($op eq 'store_var') {
        my $var = $args[0];
        print "    instr->a[$ap] = v$var; /* $comment */\n";
    } elsif ($op eq 'store_val') {
        my($type,$val) = @args;
        print <<"END";
    /* Store value $comment */
    instr->a[$ap].type = $type;
    instr->a[$ap].val = $val;
END
    } elsif ($op eq 'store_rest_args') {
        my($type,$val) = @args;
        print <<"END";
    /* Store dynamic arguments ($comment) */
    ASSERT(instr->a == instr->def_args);
    instr->arity = instr->arity + num_rest_args;
    instr->a = erts_alloc(ERTS_ALC_T_LOADER_TMP,
                          instr->arity * sizeof(BeamOpArg));
    sys_memcpy(instr->a, instr->def_args, $ap * sizeof(BeamOpArg));
    sys_memcpy(instr->a+$ap, rest_args, num_rest_args*sizeof(BeamOpArg));
END
    } elsif ($op eq 'end') {
        print <<"END";
    /* End of transformation */
    st->genop = instr;
    while (first != keep) {
      BeamOp* next = first->next;
      beamopallocator_free_op(&st->op_allocator, first);
      first = next;
    }
    return TE_OK;
END
    } elsif ($op eq 'fail') {
        print "/* Fail transformation */\n";
        print "return TE_FAIL;\n";
    } else {
        error("Unhandled instruction: $op @args");
    }
}

sub tr_gen_from {
    my($line,@tr) = @_;
    my(%var) = ();
    my(%unused) = ();
    my(%var_type);
    my($var_num) = 0;
    my(@code);
    my($op, $ref);		# Loop variables.
    my $where = "$line: (left of =>): ";
    my $may_fail = 0;
    my $is_first = 1;
    my @instrs;

    foreach $ref (@tr) {
	my($name, $arity, @ops) = @$ref;
	my($key) = "$name/$arity";
	my($opnum);

	$may_fail = 1 unless $is_first;
	$is_first = 0;

	#
	# A name starting with a period is a C pred function to be called.
	#

	if ($name =~ /^\.(\w+)/) {
	    $name = $1;
	    $may_fail = 1;
	    my $var;
	    my @args;
            my @vars;
            my @param_types;

	    foreach $var (@ops) {
                if ($var =~ /^-?\d+$/) {
                    push @args, $var;
                    push @param_types, 'Uint';
                    next;
                }
		error($where, "'$var' unbound")
		    unless defined $var{$var};
                delete $unused{$var};
                push @vars, $var;
		if ($var_type{$var} eq 'scalar') {
		    push(@args, "v$var{$var}");
                    push @param_types, 'BeamOpArg';
		} else {
		    push(@args, "rest_args");
                    push @param_types, 'BeamOpArg*';
		}
	    }
            my $c_name = "pred.$name";
            $c_param_types{$c_name} = \@param_types;
            $c_code_used{$c_name} = 1;
            my $op = make_op("$name()", 'pred', $name, @args);
            my @slots = grep(/^\d+/, map { $var{$_} } @vars);
	    op_slot_usage($op, @slots);
	    push(@code, $op);
	    next;
	}

	#
	# Check that $name/$arity refers to a valid generic instruction.
	#

	error($where, "invalid generic op $name/$arity")
	    unless defined $gen_opnum{$name,$arity};
	$opnum = $gen_opnum{$name,$arity};

	push(@code, make_op("$name/$arity", 'next_instr', $opnum));
        push @instrs, "$name/$arity";
        my $arg = 0;
	foreach $op (@ops) {
	    my($var, $type, $type_val, $cond, $val) = @$op;

	    if ($type ne '' && $type ne '*') {
		$may_fail = 1;

		#
		# The is_bif, is_not_bif, and is_func instructions have
		# their own built-in type test and don't need to
		# be guarded with a type test instruction.
		#
		unless ($cond eq 'is_bif' or
			$cond eq 'is_not_bif' or
			$cond eq 'is_func') {
		    my($types) = '';
		    my($type_mask) = 0;
		    foreach (split('', $type)) {
			$types .= "$_ ";
			$type_mask |= $type_bit{$_};
		    }
                    push(@code, make_op($types, 'is_type', $type_mask));
		}
	    }

            $arg++;
            my $var_comment = "variable $var";
            $var_comment = "argument $arg"
                if $var eq '';
	    if ($cond eq 'is_func') {
		my($m, $f, $a) = split(/:/, $val);
		$may_fail = 1;
                push @code, make_op($var_comment, $cond, "am_$m", "am_$f", $a);
	    } elsif ($cond ne '') {
		$may_fail = 1;

                push @code, make_op($var_comment, $cond, $val);
	    }

	    if ($var ne '') {
		if (defined $var{$var}) {
                    my $msg = "variable $var used more than once\n" .
                        "   (repeated variables in matching is not supported;\n" .
                        "   use the predicate equal(Var1, Var2) " .
                        "to compare variables)";
                    pending_error($where, $msg);
		} elsif ($type eq '*') {
		    foreach my $type (values %var_type) {
			error($where, "only one use of a '*' variable is " .
			      "allowed on the left hand side of " .
			      "a transformation")
			    if $type eq 'array';
		    }
		    $var{$var} = 'unnumbered';
		    $var_type{$var} = 'array';
                    push @code, make_op($var, 'rest_args', $arity);
		} else {
		    $var_type{$var} = 'scalar';
		    $var{$var} = $var_num;
		    $var_num++;
		    push(@code, make_op($var, 'set_var', $var{$var}));
		}

                $unused{$var} = 1;
	    }
            push(@code, make_op('', 'next_arg'));
	}

	# Remove redundant 'next_arg' instructions before the end
	# of the instruction.
	pop(@code) while is_instr($code[$#code], 'next_arg');
    }

    #
    # Insert the commit operation.
    #
    push(@code, make_op($may_fail ? 'This rule succeeds' :
                        'This rule always succeeds', 'commit'));

    $te_max_vars = $var_num
	if $te_max_vars < $var_num;
    [\%var, \%unused, \%var_type, \@instrs, \@code];
}

sub tr_gen_to {
    my($line, $orig_transform, $so_far, @tr) = @_;
    my($var_ref, $unused_ref, $var_type_ref, $instrs_ref, $code_ref) = @$so_far;
    my(%var) = %$var_ref;
    my(%unused) = %$unused_ref;
    my(%var_type) = %$var_type_ref;
    my(@code) = @$code_ref;
    my($op, $ref);		# Loop variables.
    my($where) = "$line: (right of =>): ";

    my $last_instr = $code[$#code];
    my $cannot_fail = is_instr($last_instr, 'commit') &&
	(get_comment($last_instr) =~ /^always/);

    foreach $ref (@tr) {
	my($name, $arity, @ops) = @$ref;

	#
	# A name starting with a period is a C function to be called.
	#

	if ($name =~ /^\.(\w+)/) {
	    $name = $1;
	    my $var;
	    my(@args);
            my @param_types;

	    foreach $var (@ops) {
		error($where, "variable '$var' unbound")
		    unless defined $var{$var};
                delete $unused{$var};

		if ($var_type{$var} eq 'scalar') {
		    push @args, "v$var{$var}";
                    push @param_types, 'BeamOpArg';
		} else {
		    push @args, "rest_args";
                    push @param_types, 'BeamOpArg*';
		}
	    }
            my $c_name = "gen.$name";
            $c_param_types{$c_name} = \@param_types;
            $c_code_used{$c_name} = 1;
	    pop(@code);	# Get rid of 'commit' instruction
	    my $op = make_op("$name()", 'call', $name, @args);
	    my @slots = grep(/^\d+/, map { $var{$_} } @ops);
	    op_slot_usage($op, @slots);
	    push(@code, $op);
	    last;
	}

	#
	# Check that $name/$arity refers to a valid generic instruction.
	#

	my($key) = "$name/$arity";
	error($where, "invalid generic op $name/$arity")
	    unless defined $gen_opnum{$name,$arity};
	my $opnum = $gen_opnum{$name,$arity};

	#
	# Create code to build the generic instruction.
	#

	push(@code, make_op("$name/$arity", 'new_instr', $opnum));
	foreach $op (@ops) {
	    my($var, $type, $type_val) = @$op;

	    if ($type eq '*') {
		push(@code, make_op($var, 'store_rest_args'));
	    } elsif ($var ne '') {
                error($where, "using explicitly unused variable '$var'. " .
                      "Remove the '_' prefix if this is intentional.")
                    unless !($var =~ /^_/);
		error($where, "variable '$var' unbound")
		    unless defined $var{$var};
		my $op = make_op($var, 'store_var', $var{$var});
		op_slot_usage($op, $var{$var});
                my $next_arg = make_op('', 'next_arg');
		push @code, $op, $next_arg;
	    } elsif ($type ne '') {
                my $val = $type_val || 0;
                my $comment = "$type=$val";
                my $store_val = make_op($comment, 'store_val', "TAG_$type", $val);
                my $next_arg = make_op('', 'next_arg');
                push @code, $store_val, $next_arg;
	    }

            delete $unused{$var};
	}

	pop(@code) if is_instr($code[$#code], 'next_arg');
    }

    foreach my $unused (keys %unused) {
        error($where,
              "variable '$unused' is unused. Prefix with '_' if this is " .
              "intentional")
            unless $unused =~ /^_/;
    }

    push(@code, make_op('', 'end'));

    tr_maybe_keep(\@code);
    tr_maybe_rename(\@code);
    combine_commit(\@code);
    tr_remove_unused(\@code);

    chain_instructions($instrs_ref, $line, $orig_transform,
                       $cannot_fail, @code);
}

#
# Chain together all codes segments having the same first instruction.
#
sub chain_instructions() {
    my($instrs_ref, $line, $orig_transform, $cannot_fail, @code) = @_;
    my($first,$second) = @$instrs_ref;

    my $tr_ref = $gen_transform{$first};

    if ($tr_ref) {
        my (undef, $cant_fail) = $$tr_ref[$#{$tr_ref}];
        if ($cant_fail) {
            error("Line $line: A previous transformation shadows '$orig_transform'");
        }
    }
    shift @code;
    my $comment = starred_comment("Line $line:", "  $orig_transform");
    push @$tr_ref, [$first,$second,$cannot_fail,$comment,@code];

    $gen_transform{$first} = $tr_ref;
}

#
# Optimize the code for transformations matching the same first
# instruction.
#

sub group_tr {
    my($lref) = @_;

    #
    # Group transformations (while keeping the order) that all match the same
    # second instruction.
    #
    for (my $i = 0; $i < @$lref; $i++) {
        my(undef,$current) = @{${$lref}[$i]};
        next unless defined $current;

        # Find the next instruction that as the same second instruction.
        for (my $j = $i + 1; $j < @$lref; $j++) {
            my(undef,$other) = @{${$lref}[$j]};

            # If this instruction does not match a second instruction,
            # we must not continue the search.
            last unless defined $other;

            if ($other eq $current) {
                # Found an instruction. If it is already the very next
                # instruction, place it directly after the current instruction.
                if ($j > $i + 1) {
                    my($el) = splice @$lref, $j, 1;
                    splice @$lref, $i, 0, ($el);
                }
                last;
            }
        }
    }

    #
    # Add 'try_me_else' instructions to try the next transformation
    # when the current transformation fails.
    #
    for (my $i = 0; $i < @$lref; $i++) {
        my($first,$second,$cannot_fail,$comment,@c) = @{${$lref}[$i]};
        unless ($cannot_fail) {
            if ($i == $#{$lref}) {
                unshift @c, make_op('', 'try_me_else_fail');
            } else {
                unshift @c, make_op('', 'try_me_else');
            }
        }
        ${$lref}[$i] = [$first,$second,$cannot_fail,$comment,@c];
    }

    #
    # Find consecutive runs of at least two transformation matching
    # the same second instruction. When a run is found, add a
    # 'skip_unless' instruction that will skip all of the instructions in the run
    # when the second instruction is wrong.
    #
    for (my $i = 0; $i < @$lref; $i++) {
        my(undef,$current) = @{${$lref}[$i]};
        next unless defined $current;
        my $j;
        my $skip_len = 0;

        for ($j = $i; $j < @$lref; $j++) {
            my(undef,$other,undef,undef,@c) = @{${$lref}[$j]};
            last unless defined $other and $other eq $current;
            $skip_len++;
        }

        if ($j > $i + 1) {
            my $num_rules_skipped = $j - $i;
            my $comment = "Skip $num_rules_skipped rules" .
                " unless the second instruction is $current.";
            $comment = starred_comment($comment);
            my($name, $arity) = split('/', $current);
            my $op = make_op('', 'skip_unless',
                             $gen_opnum{$name,$arity}, $skip_len);
            splice @$lref, $i, 0, (['','',1,$comment,$op]);
            $i = $j + 1;
            if ($j == $#{$lref}) {
                my(@c) = (make_op('wrong second instruction', 'fail'));
                push @$lref, ['','','','',@c];
            }
        }
    }
    $lref;
}

sub tr_maybe_keep {
    my($ref) = @_;
    my $ap = 1;
    my @last_instr = ('unknown','ignored');
    my $pos;
    my $reused_instr;

    for (my $i = 0; $i < @$ref; $i++) {
	my $instr = $$ref[$i];
	my($size, $instr_ref, $comment) = @$instr;
	my($op, @args) = @$instr_ref;
	if ($op eq 'next_instr') {
            @last_instr = ($args[0],'ignored');
            $ap = 1;
	} elsif ($op eq 'next_arg') {
            $ap++;
            $last_instr[$ap] = 'ignored'
                unless defined $pos;
	} elsif ($op eq 'set_var') {
	    $last_instr[$ap] = $args[0];
	} elsif ($op eq 'new_instr') {
	    unless (defined $pos) {
		# 'new_instr' immediately after 'commit'.
		$reused_instr = $args[0];
		return unless $last_instr[0] == $reused_instr;
		$pos = $i - 1;
                $ap = 1;
	    } else {
		# Second 'new_instr' after 'commit'. The instructions
		# from $pos up to and including $i - 1 rebuilds the
		# existing instruction exactly.
		my $name = $gen_opname[$reused_instr];
		my $arity = $gen_arity[$reused_instr];
		my $reuse = make_op("$name/$arity", 'keep');
		splice @$ref, $pos, $i-$pos, ($reuse);
		return;
	    }
	} elsif ($op eq 'store_var') {
	    return unless $last_instr[$ap] eq $args[0];
	} elsif (defined $pos) {
	    return;
	}
    }
}

sub combine_commit {
    my($ref) = @_;

    for (my $i = 1; $i < @$ref; $i++) {
        my $instr = $$ref[$i];
	my($size, $instr_ref, $comment) = @$instr;
	my($op, @args) = @$instr_ref;
        if ($op eq 'rest_args') {
            return;
        } elsif ($op eq 'new_instr' and is_instr($$ref[$i-1], 'commit')) {
            $comment = get_comment($$ref[$i-1]);
            my $op = make_op($comment, 'commit_new_instr', @args);
            splice @$ref, $i - 1, 2, ($op);
        }
    }
}

sub tr_maybe_rename {
    my($ref) = @_;
    my $s = 'left';
    my $a = 0;
    my $num_args = 0;
    my $new_instr;
    my $first;
    my $i;

    for ($i = 1; $i < @$ref; $i++) {
	my $instr = $$ref[$i];
	my($size, $instr_ref, $comment) = @$instr;
	my($op, @args) = @$instr_ref;

	if ($s eq 'left') {
            if ($op eq 'next_arg') {
		$a++;
	    } elsif ($op eq 'commit') {
		$a = 0;
		$first = $i;
		$s = 'committed';
	    } elsif ($op eq 'next_instr') {
		return;
	    }
	} elsif ($s eq 'committed') {
	    if ($op eq 'new_instr') {
		$new_instr = $args[0];
		$a = 0;
		$s = 'right';
	    } else {
		return;
	    }
	} elsif ($s eq 'right') {
            if ($op eq 'end' && $a <= $num_args) {
		my $name = $gen_opname[$new_instr];
		my $arity = $gen_arity[$new_instr];
		my $new_op = make_op("$name/$arity", 'rename', $new_instr);
		splice @$ref, $first, $i-$first+1, ($new_op);
		return;
	    } else {
		return;
	    }
	}
    }
}

sub tr_remove_unused {
    my($ref) = @_;
    my %used;

    # Collect all used variables.
    for my $instr (@$ref) {
	my $uref = $$instr[3];
	for my $slot (@$uref) {
	    $used{$slot} = 1;
	}
    }

    # If a variable is not used, don't store the variable.
    for my $instr (@$ref) {
	my($size, $instr_ref, $comment) = @$instr;
	my($op, @args) = @$instr_ref;
	if ($op eq 'set_var') {
	    my $var = $args[0];
	    next if $used{$var};
	    $instr = make_op("(ignoring unused variable $comment)", 'nop');
        }
    }

    # Delete a sequence of 'next_arg' instructions when they are
    # redundant before instructions such as 'commit'.
    my @opcode;
    my %ending = (call_end => 1,
		  commit => 1,
		  next_instr => 1,
		  pred => 1,
		  rename => 1,
		  keep => 1);
    for (my $i = 0; $i < @$ref; $i++) {
	my $instr = $$ref[$i];
	my($size, $instr_ref, $comment) = @$instr;
	my($opcode) = @$instr_ref;

	if ($ending{$opcode}) {
	    my $first = $i;
	    $first-- while $first > 0 and $opcode[$first-1] eq 'next_arg';
	    my $n = $i - $first;
	    splice @$ref, $first, $n;
	    $i -= $n;
	}
	$opcode[$i] = $opcode;
    }
}

sub gen_tr_code {
    my($prefix) = @_;

    foreach my $name (sort keys %c_code) {
        if (index($name, $prefix) == 0) {
            my $func_name = $name;
            $func_name =~ s/^$prefix//;
            my($block,$where,@params) = @{$c_code{$name}};
            my %bindings;
            $block = eval { expand_all($block, \%bindings) };
            unless (defined $block) {
                warn $@;
                error("... from the body of $name at $where");
            }
            my $head = 'static ';
            $head .= $prefix eq 'pred.' ? 'int' : 'BeamOp*';
            $head .= " $func_name(LoaderState* S";
            my(@param_types);
            if (defined $c_param_types{$name}) {
                @param_types = @{$c_param_types{$name}};
            } else {
                @param_types = ('BeamOpArg') x @params;
            }
            for (my $i = 0; $i < @params; $i++) {
                $head .= ", $param_types[$i] $params[$i]";
            }
            $head .= ") {\n";
            my $code = $head . "$block;\n}\n";
            print_indented_code($code);
        }
    }
}

sub make_op {
    my($comment, @op) = @_;
    [scalar(@op), [@op], $comment, []];
}

sub op_slot_usage {
    my($op_ref, @slots) = @_;
    $$op_ref[3] = \@slots;
}

sub is_instr {
    my($ref,$op) = @_;
    return 0 unless ref($ref) eq 'ARRAY';
    $ref->[1][0] eq $op;
}

sub get_comment {
    my($ref,$op) = @_;
    return '' unless ref($ref) eq 'ARRAY';
    $ref->[2];
}

sub starred_comment {
    "\n/*" . join("\n * ", '', @_) . "\n */\n\n";
}

sub include_files() {
    print "#ifdef HAVE_CONFIG_H\n";
    print "#  include \"config.h\"\n";
    print "#endif\n\n";
    print '#include "sys.h"', "\n";
    print '#include "erl_vm.h"', "\n";
    print '#include "export.h"', "\n";
    print '#include "erl_process.h"', "\n";
    print '#include "bif.h"', "\n";
    print '#include "erl_atom_table.h"', "\n";
    print '#include "beam_load.h"', "\n";
    print "\n";
}

# Converts a sign string to its most specific argument class, e.g. "an" becomes
# 'ArgImmed' because both are immediates, and "anx" becomes 'ArgSource' because
# all of them are sources.
sub get_jit_class {
    my $signs__ = shift;
    $signs__ =~ s/[?]//g;

    my @signs = split //, $signs__;

    my $type = $arg_jit_class{shift(@signs)};
    my $combined_bits = $arg_jit_lattice{$type};

    foreach my $sign (@signs) {
        my $next_type = $arg_jit_class{$sign};
        my $next_bits = $arg_jit_lattice{$next_type};

        $combined_bits &= $next_bits;
    }

    return $arg_jit_lattice{$combined_bits};
}
